1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2001-2003
5 -- Access to system tools: gcc, cp, rm etc
7 -----------------------------------------------------------------------------
14 getTopDir, -- IO String -- The value of $topdir
15 getPackageConfigPath, -- IO String -- Where package.conf is
16 getUsageMsgPaths, -- IO (String,String)
18 -- Interface to system tools
19 runUnlit, runCpp, runCc, -- [Option] -> IO ()
20 runPp, -- [Option] -> IO ()
21 runMangle, runSplit, -- [Option] -> IO ()
22 runAs, runLink, -- [Option] -> IO ()
25 touch, -- String -> String -> IO ()
26 copy, -- String -> String -> String -> IO ()
27 normalisePath, -- FilePath -> FilePath
29 -- Temporary-file management
32 cleanTempFiles, cleanTempFilesExcept,
36 system, -- String -> IO ExitCode
39 getSysMan, -- IO String Parallel system only
45 #include "HsVersions.h"
47 import DriverPhases ( isHaskellUserSrcFilename )
50 import ErrUtils ( putMsg )
51 import Panic ( GhcException(..) )
52 import Util ( Suffix, global, notNull, consIORef,
53 normalisePath, pgmPath, platformPath )
54 import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..),
55 setTmpDir, defaultDynFlags )
57 import EXCEPTION ( throwDyn )
58 import DATA_IOREF ( IORef, readIORef, writeIORef )
61 import Monad ( when, unless )
62 import System ( ExitCode(..), getEnv, system )
63 import IO ( try, catch,
64 openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
66 import Directory ( doesFileExist, removeFile )
67 import List ( partition )
69 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
70 -- lines on mingw32, so we disallow it now.
71 #if __GLASGOW_HASKELL__ < 500
72 #error GHC >= 5.00 is required for bootstrapping GHC
75 #ifndef mingw32_HOST_OS
76 #if __GLASGOW_HASKELL__ > 504
77 import qualified System.Posix.Internals
79 import qualified Posix
81 #else /* Must be Win32 */
82 import List ( isPrefixOf )
83 import Util ( dropList )
85 import CString ( CString, peekCString )
88 #if __GLASGOW_HASKELL__ < 603
89 -- rawSystem comes from libghccompat.a in stage1
90 import Compat.RawSystem ( rawSystem )
92 import System.Cmd ( rawSystem )
97 The configuration story
98 ~~~~~~~~~~~~~~~~~~~~~~~
100 GHC needs various support files (library packages, RTS etc), plus
101 various auxiliary programs (cp, gcc, etc). It finds these in one
104 * When running as an *installed program*, GHC finds most of this support
105 stuff in the installed library tree. The path to this tree is passed
106 to GHC via the -B flag, and given to initSysTools .
108 * When running *in-place* in a build tree, GHC finds most of this support
109 stuff in the build tree. The path to the build tree is, again passed
112 GHC tells which of the two is the case by seeing whether package.conf
113 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
116 SysTools.initSysProgs figures out exactly where all the auxiliary programs
117 are, and initialises mutable variables to make it easy to call them.
118 To to this, it makes use of definitions in Config.hs, which is a Haskell
119 file containing variables whose value is figured out by the build system.
121 Config.hs contains two sorts of things
123 cGCC, The *names* of the programs
126 etc They do *not* include paths
129 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
130 cSPLIT_DIR_REL *relative* to the root of the build tree,
131 for use when running *in-place* in a build tree (only)
135 ---------------------------------------------
136 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
138 Another hair-brained scheme for simplifying the current tool location
139 nightmare in GHC: Simon originally suggested using another
140 configuration file along the lines of GCC's specs file - which is fine
141 except that it means adding code to read yet another configuration
142 file. What I didn't notice is that the current package.conf is
143 general enough to do this:
146 {name = "tools", import_dirs = [], source_dirs = [],
147 library_dirs = [], hs_libraries = [], extra_libraries = [],
148 include_dirs = [], c_includes = [], package_deps = [],
149 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
150 extra_cc_opts = [], extra_ld_opts = []}
152 Which would have the advantage that we get to collect together in one
153 place the path-specific package stuff with the path-specific tool
156 ---------------------------------------------
159 %************************************************************************
161 \subsection{Global variables to contain system programs}
163 %************************************************************************
165 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
166 (See remarks under pathnames below)
169 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
170 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
172 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
173 GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String))
175 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
177 -- Parallel system only
178 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
180 -- ways to get at some of these variables from outside this module
181 getPackageConfigPath = readIORef v_Path_package_config
182 getTopDir = readIORef v_TopDir
186 %************************************************************************
188 \subsection{Initialisation}
190 %************************************************************************
193 initSysTools :: [String] -- Command-line arguments starting "-B"
196 -> IO DynFlags -- Set all the mutable variables above, holding
197 -- (a) the system programs
198 -- (b) the package-config file
199 -- (c) the GHC usage message
202 initSysTools minusB_args dflags
203 = do { (am_installed, top_dir) <- findTopDir minusB_args
204 ; writeIORef v_TopDir top_dir
206 -- for "installed" this is the root of GHC's support files
207 -- for "in-place" it is the root of the build tree
208 -- NB: top_dir is assumed to be in standard Unix format '/' separated
210 ; let installed, installed_bin :: FilePath -> FilePath
211 installed_bin pgm = pgmPath top_dir pgm
212 installed file = pgmPath top_dir file
213 inplace dir pgm = pgmPath (top_dir `slash`
214 cPROJECT_DIR `slash` dir) pgm
217 | am_installed = installed "package.conf"
218 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
221 | am_installed = installed "ghc-usage.txt"
222 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
225 | am_installed = installed "ghci-usage.txt"
226 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
228 -- For all systems, unlit, split, mangle are GHC utilities
229 -- architecture-specific stuff is done when building Config.hs
231 | am_installed = installed_bin cGHC_UNLIT_PGM
232 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
234 -- split and mangle are Perl scripts
236 | am_installed = installed_bin cGHC_SPLIT_PGM
237 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
240 | am_installed = installed_bin cGHC_MANGLER_PGM
241 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
243 ; let dflags0 = defaultDynFlags
244 #ifndef mingw32_HOST_OS
245 -- check whether TMPDIR is set in the environment
246 ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
248 -- On Win32, consult GetTempPath() for a temp dir.
249 -- => it first tries TMP, TEMP, then finally the
250 -- Windows directory(!). The directory is in short-path
254 let len = (2048::Int)
255 buf <- mallocArray len
256 ret <- getTempPath len buf
258 -- failed, consult TMPDIR.
266 ; let dflags1 = case e_tmpdir of
268 Right d -> setTmpDir d dflags0
270 -- Check that the package config exists
271 ; config_exists <- doesFileExist pkgconfig_path
272 ; when (not config_exists) $
273 throwDyn (InstallationError
274 ("Can't find package.conf as " ++ pkgconfig_path))
276 #if defined(mingw32_HOST_OS)
277 -- WINDOWS-SPECIFIC STUFF
278 -- On Windows, gcc and friends are distributed with GHC,
279 -- so when "installed" we look in TopDir/bin
280 -- When "in-place" we look wherever the build-time configure
282 -- When "install" we tell gcc where its specs file + exes are (-B)
283 -- and also some places to pick up include files. We need
284 -- to be careful to put all necessary exes in the -B place
285 -- (as, ld, cc1, etc) since if they don't get found there, gcc
286 -- then tries to run unadorned "as", "ld", etc, and will
287 -- pick up whatever happens to be lying around in the path,
288 -- possibly including those from a cygwin install on the target,
289 -- which is exactly what we're trying to avoid.
290 ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
292 | am_installed = (installed_bin "gcc", [gcc_b_arg])
293 | otherwise = (cGCC, [])
294 -- The trailing "/" is absolutely essential; gcc seems
295 -- to construct file names simply by concatenating to
296 -- this -B path with no extra slash We use "/" rather
297 -- than "\\" because otherwise "\\\" is mangled
298 -- later on; although gcc_args are in NATIVE format,
300 -- (see comments with declarations of global variables)
302 -- The quotes round the -B argument are in case TopDir
305 perl_path | am_installed = installed_bin cGHC_PERL
306 | otherwise = cGHC_PERL
308 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
309 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
310 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
312 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
313 -- a call to Perl to get the invocation of split and mangle
314 ; let (split_prog, split_args) = (perl_path, [Option split_script])
315 (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
317 ; let (mkdll_prog, mkdll_args)
319 (pgmPath (installed "gcc-lib/") cMKDLL,
320 [ Option "--dlltool-name",
321 Option (pgmPath (installed "gcc-lib/") "dlltool"),
322 Option "--driver-name",
323 Option gcc_prog, gcc_b_arg ])
324 | otherwise = (cMKDLL, [])
326 -- UNIX-SPECIFIC STUFF
327 -- On Unix, the "standard" tools are assumed to be
328 -- in the same place whether we are running "in-place" or "installed"
329 -- That place is wherever the build-time configure script found them.
330 ; let gcc_prog = cGCC
333 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
336 -- On Unix, scripts are invoked using the '#!' method. Binary
337 -- installations of GHC on Unix place the correct line on the front
338 -- of the script at installation time, so we don't want to wire-in
339 -- our knowledge of $(PERL) on the host system here.
340 ; let (split_prog, split_args) = (split_script, [])
341 (mangle_prog, mangle_args) = (mangle_script, [])
344 -- cpp is derived from gcc on all platforms
345 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
346 -- Config.hs one day.
347 ; let cpp_path = (gcc_prog, gcc_args ++
348 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
350 -- For all systems, copy and remove are provided by the host
351 -- system; architecture-specific stuff is done when building Config.hs
352 ; let cp_path = cGHC_CP
354 -- Other things being equal, as and ld are simply gcc
355 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
356 (ld_prog,ld_args) = (gcc_prog,gcc_args)
358 -- Initialise the global vars
359 ; writeIORef v_Path_package_config pkgconfig_path
360 ; writeIORef v_Path_usages (ghc_usage_msg_path,
363 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
364 -- Hans: this isn't right in general, but you can
365 -- elaborate it in the same way as the others
367 ; writeIORef v_Pgm_T touch_path
368 ; writeIORef v_Pgm_CP cp_path
374 pgm_c = (gcc_prog,gcc_args),
375 pgm_m = (mangle_prog,mangle_args),
376 pgm_s = (split_prog,split_args),
377 pgm_a = (as_prog,as_args),
378 pgm_l = (ld_prog,ld_args),
379 pgm_dll = (mkdll_prog,mkdll_args) }
382 #if defined(mingw32_HOST_OS)
383 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
389 -- for "installed" this is the root of GHC's support files
390 -- for "in-place" it is the root of the build tree
393 -- 1. Set proto_top_dir
394 -- a) look for (the last) -B flag, and use it
395 -- b) if there are no -B flags, get the directory
396 -- where GHC is running (only on Windows)
398 -- 2. If package.conf exists in proto_top_dir, we are running
399 -- installed; and TopDir = proto_top_dir
401 -- 3. Otherwise we are running in-place, so
402 -- proto_top_dir will be /...stuff.../ghc/compiler
403 -- Set TopDir to /...stuff..., which is the root of the build tree
405 -- This is very gruesome indeed
407 findTopDir :: [String]
408 -> IO (Bool, -- True <=> am installed, False <=> in-place
409 String) -- TopDir (in Unix format '/' separated)
412 = do { top_dir <- get_proto
413 -- Discover whether we're running in a build tree or in an installation,
414 -- by looking for the package configuration file.
415 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
417 ; return (am_installed, top_dir)
420 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
421 get_proto | notNull minusbs
422 = return (normalisePath (drop 2 (last minusbs))) -- 2 for "-B"
424 = do { maybe_exec_dir <- getBaseDir -- Get directory of executable
425 ; case maybe_exec_dir of -- (only works on Windows;
426 -- returns Nothing on Unix)
427 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
428 Just dir -> return dir
433 %************************************************************************
435 \subsection{Running an external program}
437 %************************************************************************
441 runUnlit :: DynFlags -> [Option] -> IO ()
442 runUnlit dflags args = do
444 runSomething dflags "Literate pre-processor" p args
446 runCpp :: DynFlags -> [Option] -> IO ()
447 runCpp dflags args = do
448 let (p,args0) = pgm_P dflags
449 runSomething dflags "C pre-processor" p (args0 ++ args)
451 runPp :: DynFlags -> [Option] -> IO ()
452 runPp dflags args = do
454 runSomething dflags "Haskell pre-processor" p args
456 runCc :: DynFlags -> [Option] -> IO ()
457 runCc dflags args = do
458 let (p,args0) = pgm_c dflags
459 runSomething dflags "C Compiler" p (args0++args)
461 runMangle :: DynFlags -> [Option] -> IO ()
462 runMangle dflags args = do
463 let (p,args0) = pgm_m dflags
464 runSomething dflags "Mangler" p (args0++args)
466 runSplit :: DynFlags -> [Option] -> IO ()
467 runSplit dflags args = do
468 let (p,args0) = pgm_s dflags
469 runSomething dflags "Splitter" p (args0++args)
471 runAs :: DynFlags -> [Option] -> IO ()
472 runAs dflags args = do
473 let (p,args0) = pgm_a dflags
474 runSomething dflags "Assembler" p (args0++args)
476 runLink :: DynFlags -> [Option] -> IO ()
477 runLink dflags args = do
478 let (p,args0) = pgm_l dflags
479 runSomething dflags "Linker" p (args0++args)
481 runMkDLL :: DynFlags -> [Option] -> IO ()
482 runMkDLL dflags args = do
483 let (p,args0) = pgm_dll dflags
484 runSomething dflags "Make DLL" p (args0++args)
486 touch :: DynFlags -> String -> String -> IO ()
487 touch dflags purpose arg = do
488 p <- readIORef v_Pgm_T
489 runSomething dflags purpose p [FileOption "" arg]
491 copy :: DynFlags -> String -> String -> String -> IO ()
492 copy dflags purpose from to = do
493 when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
495 h <- openFile to WriteMode
496 ls <- readFile from -- inefficient, but it'll do for now.
497 -- ToDo: speed up via slurping.
504 getSysMan :: IO String -- How to invoke the system manager
505 -- (parallel system only)
506 getSysMan = readIORef v_Pgm_sysman
510 getUsageMsgPaths :: IO (FilePath,FilePath)
511 -- the filenames of the usage messages (ghc, ghci)
512 getUsageMsgPaths = readIORef v_Path_usages
516 %************************************************************************
518 \subsection{Managing temporary files
520 %************************************************************************
523 GLOBAL_VAR(v_FilesToClean, [], [String] )
527 cleanTempFiles :: DynFlags -> IO ()
528 cleanTempFiles dflags
529 = do fs <- readIORef v_FilesToClean
530 removeTmpFiles dflags fs
531 writeIORef v_FilesToClean []
533 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
534 cleanTempFilesExcept dflags dont_delete
535 = do files <- readIORef v_FilesToClean
536 let (to_keep, to_delete) = partition (`elem` dont_delete) files
537 removeTmpFiles dflags to_delete
538 writeIORef v_FilesToClean to_keep
541 -- find a temporary name that doesn't already exist.
542 newTempName :: DynFlags -> Suffix -> IO FilePath
543 newTempName DynFlags{tmpDir=tmp_dir} extn
544 = do x <- getProcessID
545 findTempName tmp_dir x
547 findTempName tmp_dir x
548 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
549 b <- doesFileExist filename
550 if b then findTempName tmp_dir (x+1)
551 else do consIORef v_FilesToClean filename -- clean it up later
554 addFilesToClean :: [FilePath] -> IO ()
555 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
556 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
558 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
559 removeTmpFiles dflags fs
561 traceCmd dflags "Deleting temp files"
562 ("Deleting: " ++ unwords deletees)
565 verb = verbosity dflags
567 -- Flat out refuse to delete files that are likely to be source input
568 -- files (is there a worse bug than having a compiler delete your source
571 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
574 | null non_deletees = act
576 hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
579 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
581 rm f = removeFile f `IO.catch`
584 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
588 -----------------------------------------------------------------------------
589 -- Running an external program
591 runSomething :: DynFlags
592 -> String -- For -v message
593 -> String -- Command name (possibly a full path)
594 -- assumed already dos-ified
595 -> [Option] -- Arguments
596 -- runSomething will dos-ify them
599 runSomething dflags phase_name pgm args = do
600 let real_args = filter notNull (map showOpt args)
601 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
602 exit_code <- rawSystem pgm real_args
606 -- rawSystem returns (ExitFailure 127) if the exec failed for any
607 -- reason (eg. the program doesn't exist). This is the only clue
608 -- we have, but we need to report something to the user because in
609 -- the case of a missing program there will otherwise be no output
612 throwDyn (InstallationError ("could not execute: " ++ pgm))
613 ExitFailure _other ->
614 throwDyn (PhaseFailed phase_name exit_code)
616 showOpt (FileOption pre f) = pre ++ platformPath f
617 showOpt (Option "") = ""
618 showOpt (Option s) = s
620 traceCmd :: DynFlags -> 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 dflags phase_name cmd_line action
624 = do { let verb = verbosity dflags
625 ; when (verb >= 2) $ putMsg ("*** " ++ phase_name)
626 ; when (verb >= 3) $ putMsg cmd_line
630 ; unless (dopt Opt_DryRun dflags) $ do {
633 ; action `IO.catch` handle_exn verb
636 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
637 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
638 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
641 -----------------------------------------------------------------------------
642 Path name construction
645 slash :: String -> String -> String
646 slash s1 s2 = s1 ++ ('/' : s2)
650 %************************************************************************
652 \subsection{Support code}
654 %************************************************************************
657 -----------------------------------------------------------------------------
658 -- Define getBaseDir :: IO (Maybe String)
660 getBaseDir :: IO (Maybe String)
661 #if defined(mingw32_HOST_OS)
662 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
663 -- return the path $(stuff). Note that we drop the "bin/" directory too.
664 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
665 buf <- mallocArray len
666 ret <- getModuleFileName nullPtr buf len
667 if ret == 0 then free buf >> return Nothing
668 else do s <- peekCString buf
670 return (Just (rootDir s))
672 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
674 foreign import stdcall unsafe "GetModuleFileNameA"
675 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
677 getBaseDir = return Nothing
680 #ifdef mingw32_HOST_OS
681 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
682 #elif __GLASGOW_HASKELL__ > 504
683 getProcessID :: IO Int
684 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
686 getProcessID :: IO Int
687 getProcessID = Posix.getProcessID