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 Panic ( GhcException(..) )
51 import Util ( Suffix, global, notNull, consIORef,
52 normalisePath, pgmPath, platformPath )
53 import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..),
54 setTmpDir, defaultDynFlags )
56 import EXCEPTION ( throwDyn )
57 import DATA_IOREF ( IORef, readIORef, writeIORef )
60 import Monad ( when, unless )
61 import System ( ExitCode(..), getEnv, system )
62 import IO ( try, catch,
63 openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
65 import Directory ( doesFileExist, removeFile )
66 import List ( partition )
68 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
69 -- lines on mingw32, so we disallow it now.
70 #if __GLASGOW_HASKELL__ < 500
71 #error GHC >= 5.00 is required for bootstrapping GHC
74 #ifndef mingw32_HOST_OS
75 #if __GLASGOW_HASKELL__ > 504
76 import qualified System.Posix.Internals
78 import qualified Posix
80 #else /* Must be Win32 */
81 import List ( isPrefixOf )
82 import Util ( dropList )
84 import CString ( CString, peekCString )
87 #if __GLASGOW_HASKELL__ < 603
88 -- rawSystem comes from libghccompat.a in stage1
89 import Compat.RawSystem ( rawSystem )
91 import System.Cmd ( rawSystem )
96 The configuration story
97 ~~~~~~~~~~~~~~~~~~~~~~~
99 GHC needs various support files (library packages, RTS etc), plus
100 various auxiliary programs (cp, gcc, etc). It finds these in one
103 * When running as an *installed program*, GHC finds most of this support
104 stuff in the installed library tree. The path to this tree is passed
105 to GHC via the -B flag, and given to initSysTools .
107 * When running *in-place* in a build tree, GHC finds most of this support
108 stuff in the build tree. The path to the build tree is, again passed
111 GHC tells which of the two is the case by seeing whether package.conf
112 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
115 SysTools.initSysProgs figures out exactly where all the auxiliary programs
116 are, and initialises mutable variables to make it easy to call them.
117 To to this, it makes use of definitions in Config.hs, which is a Haskell
118 file containing variables whose value is figured out by the build system.
120 Config.hs contains two sorts of things
122 cGCC, The *names* of the programs
125 etc They do *not* include paths
128 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
129 cSPLIT_DIR_REL *relative* to the root of the build tree,
130 for use when running *in-place* in a build tree (only)
134 ---------------------------------------------
135 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
137 Another hair-brained scheme for simplifying the current tool location
138 nightmare in GHC: Simon originally suggested using another
139 configuration file along the lines of GCC's specs file - which is fine
140 except that it means adding code to read yet another configuration
141 file. What I didn't notice is that the current package.conf is
142 general enough to do this:
145 {name = "tools", import_dirs = [], source_dirs = [],
146 library_dirs = [], hs_libraries = [], extra_libraries = [],
147 include_dirs = [], c_includes = [], package_deps = [],
148 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
149 extra_cc_opts = [], extra_ld_opts = []}
151 Which would have the advantage that we get to collect together in one
152 place the path-specific package stuff with the path-specific tool
155 ---------------------------------------------
158 %************************************************************************
160 \subsection{Global variables to contain system programs}
162 %************************************************************************
164 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
165 (See remarks under pathnames below)
168 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
169 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
171 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
172 GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String))
174 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
176 -- Parallel system only
177 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
179 -- ways to get at some of these variables from outside this module
180 getPackageConfigPath = readIORef v_Path_package_config
181 getTopDir = readIORef v_TopDir
185 %************************************************************************
187 \subsection{Initialisation}
189 %************************************************************************
192 initSysTools :: [String] -- Command-line arguments starting "-B"
195 -> IO DynFlags -- Set all the mutable variables above, holding
196 -- (a) the system programs
197 -- (b) the package-config file
198 -- (c) the GHC usage message
201 initSysTools minusB_args dflags
202 = do { (am_installed, top_dir) <- findTopDir minusB_args
203 ; writeIORef v_TopDir top_dir
205 -- for "installed" this is the root of GHC's support files
206 -- for "in-place" it is the root of the build tree
207 -- NB: top_dir is assumed to be in standard Unix format '/' separated
209 ; let installed, installed_bin :: FilePath -> FilePath
210 installed_bin pgm = pgmPath top_dir pgm
211 installed file = pgmPath top_dir file
212 inplace dir pgm = pgmPath (top_dir `slash`
213 cPROJECT_DIR `slash` dir) pgm
216 | am_installed = installed "package.conf"
217 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
220 | am_installed = installed "ghc-usage.txt"
221 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
224 | am_installed = installed "ghci-usage.txt"
225 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
227 -- For all systems, unlit, split, mangle are GHC utilities
228 -- architecture-specific stuff is done when building Config.hs
230 | am_installed = installed_bin cGHC_UNLIT_PGM
231 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
233 -- split and mangle are Perl scripts
235 | am_installed = installed_bin cGHC_SPLIT_PGM
236 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
239 | am_installed = installed_bin cGHC_MANGLER_PGM
240 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
242 ; let dflags0 = defaultDynFlags
243 #ifndef mingw32_HOST_OS
244 -- check whether TMPDIR is set in the environment
245 ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
247 -- On Win32, consult GetTempPath() for a temp dir.
248 -- => it first tries TMP, TEMP, then finally the
249 -- Windows directory(!). The directory is in short-path
253 let len = (2048::Int)
254 buf <- mallocArray len
255 ret <- getTempPath len buf
257 -- failed, consult TMPDIR.
265 ; let dflags1 = case e_tmpdir of
267 Right d -> setTmpDir d dflags0
269 -- Check that the package config exists
270 ; config_exists <- doesFileExist pkgconfig_path
271 ; when (not config_exists) $
272 throwDyn (InstallationError
273 ("Can't find package.conf as " ++ pkgconfig_path))
275 #if defined(mingw32_HOST_OS)
276 -- WINDOWS-SPECIFIC STUFF
277 -- On Windows, gcc and friends are distributed with GHC,
278 -- so when "installed" we look in TopDir/bin
279 -- When "in-place" we look wherever the build-time configure
281 -- When "install" we tell gcc where its specs file + exes are (-B)
282 -- and also some places to pick up include files. We need
283 -- to be careful to put all necessary exes in the -B place
284 -- (as, ld, cc1, etc) since if they don't get found there, gcc
285 -- then tries to run unadorned "as", "ld", etc, and will
286 -- pick up whatever happens to be lying around in the path,
287 -- possibly including those from a cygwin install on the target,
288 -- which is exactly what we're trying to avoid.
289 ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
291 | am_installed = (installed_bin "gcc", [gcc_b_arg])
292 | otherwise = (cGCC, [])
293 -- The trailing "/" is absolutely essential; gcc seems
294 -- to construct file names simply by concatenating to
295 -- this -B path with no extra slash We use "/" rather
296 -- than "\\" because otherwise "\\\" is mangled
297 -- later on; although gcc_args are in NATIVE format,
299 -- (see comments with declarations of global variables)
301 -- The quotes round the -B argument are in case TopDir
304 perl_path | am_installed = installed_bin cGHC_PERL
305 | otherwise = cGHC_PERL
307 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
308 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
309 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
311 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
312 -- a call to Perl to get the invocation of split and mangle
313 ; let (split_prog, split_args) = (perl_path, [Option split_script])
314 (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
316 ; let (mkdll_prog, mkdll_args)
318 (pgmPath (installed "gcc-lib/") cMKDLL,
319 [ Option "--dlltool-name",
320 Option (pgmPath (installed "gcc-lib/") "dlltool"),
321 Option "--driver-name",
322 Option gcc_prog, gcc_b_arg ])
323 | otherwise = (cMKDLL, [])
325 -- UNIX-SPECIFIC STUFF
326 -- On Unix, the "standard" tools are assumed to be
327 -- in the same place whether we are running "in-place" or "installed"
328 -- That place is wherever the build-time configure script found them.
329 ; let gcc_prog = cGCC
332 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
335 -- On Unix, scripts are invoked using the '#!' method. Binary
336 -- installations of GHC on Unix place the correct line on the front
337 -- of the script at installation time, so we don't want to wire-in
338 -- our knowledge of $(PERL) on the host system here.
339 ; let (split_prog, split_args) = (split_script, [])
340 (mangle_prog, mangle_args) = (mangle_script, [])
343 -- cpp is derived from gcc on all platforms
344 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
345 -- Config.hs one day.
346 ; let cpp_path = (gcc_prog, gcc_args ++
347 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
349 -- For all systems, copy and remove are provided by the host
350 -- system; architecture-specific stuff is done when building Config.hs
351 ; let cp_path = cGHC_CP
353 -- Other things being equal, as and ld are simply gcc
354 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
355 (ld_prog,ld_args) = (gcc_prog,gcc_args)
357 -- Initialise the global vars
358 ; writeIORef v_Path_package_config pkgconfig_path
359 ; writeIORef v_Path_usages (ghc_usage_msg_path,
362 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
363 -- Hans: this isn't right in general, but you can
364 -- elaborate it in the same way as the others
366 ; writeIORef v_Pgm_T touch_path
367 ; writeIORef v_Pgm_CP cp_path
373 pgm_c = (gcc_prog,gcc_args),
374 pgm_m = (mangle_prog,mangle_args),
375 pgm_s = (split_prog,split_args),
376 pgm_a = (as_prog,as_args),
377 pgm_l = (ld_prog,ld_args),
378 pgm_dll = (mkdll_prog,mkdll_args) }
381 #if defined(mingw32_HOST_OS)
382 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
388 -- for "installed" this is the root of GHC's support files
389 -- for "in-place" it is the root of the build tree
392 -- 1. Set proto_top_dir
393 -- a) look for (the last) -B flag, and use it
394 -- b) if there are no -B flags, get the directory
395 -- where GHC is running (only on Windows)
397 -- 2. If package.conf exists in proto_top_dir, we are running
398 -- installed; and TopDir = proto_top_dir
400 -- 3. Otherwise we are running in-place, so
401 -- proto_top_dir will be /...stuff.../ghc/compiler
402 -- Set TopDir to /...stuff..., which is the root of the build tree
404 -- This is very gruesome indeed
406 findTopDir :: [String]
407 -> IO (Bool, -- True <=> am installed, False <=> in-place
408 String) -- TopDir (in Unix format '/' separated)
411 = do { top_dir <- get_proto
412 -- Discover whether we're running in a build tree or in an installation,
413 -- by looking for the package configuration file.
414 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
416 ; return (am_installed, top_dir)
419 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
420 get_proto | notNull minusbs
421 = return (normalisePath (drop 2 (last minusbs))) -- 2 for "-B"
423 = do { maybe_exec_dir <- getBaseDir -- Get directory of executable
424 ; case maybe_exec_dir of -- (only works on Windows;
425 -- returns Nothing on Unix)
426 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
427 Just dir -> return dir
432 %************************************************************************
434 \subsection{Running an external program}
436 %************************************************************************
440 runUnlit :: DynFlags -> [Option] -> IO ()
441 runUnlit dflags args = do
443 runSomething dflags "Literate pre-processor" p args
445 runCpp :: DynFlags -> [Option] -> IO ()
446 runCpp dflags args = do
447 let (p,args0) = pgm_P dflags
448 runSomething dflags "C pre-processor" p (args0 ++ args)
450 runPp :: DynFlags -> [Option] -> IO ()
451 runPp dflags args = do
453 runSomething dflags "Haskell pre-processor" p args
455 runCc :: DynFlags -> [Option] -> IO ()
456 runCc dflags args = do
457 let (p,args0) = pgm_c dflags
458 runSomething dflags "C Compiler" p (args0++args)
460 runMangle :: DynFlags -> [Option] -> IO ()
461 runMangle dflags args = do
462 let (p,args0) = pgm_m dflags
463 runSomething dflags "Mangler" p (args0++args)
465 runSplit :: DynFlags -> [Option] -> IO ()
466 runSplit dflags args = do
467 let (p,args0) = pgm_s dflags
468 runSomething dflags "Splitter" p (args0++args)
470 runAs :: DynFlags -> [Option] -> IO ()
471 runAs dflags args = do
472 let (p,args0) = pgm_a dflags
473 runSomething dflags "Assembler" p (args0++args)
475 runLink :: DynFlags -> [Option] -> IO ()
476 runLink dflags args = do
477 let (p,args0) = pgm_l dflags
478 runSomething dflags "Linker" p (args0++args)
480 runMkDLL :: DynFlags -> [Option] -> IO ()
481 runMkDLL dflags args = do
482 let (p,args0) = pgm_dll dflags
483 runSomething dflags "Make DLL" p (args0++args)
485 touch :: DynFlags -> String -> String -> IO ()
486 touch dflags purpose arg = do
487 p <- readIORef v_Pgm_T
488 runSomething dflags purpose p [FileOption "" arg]
490 copy :: DynFlags -> String -> String -> String -> IO ()
491 copy dflags purpose from to = do
492 when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
494 h <- openFile to WriteMode
495 ls <- readFile from -- inefficient, but it'll do for now.
496 -- ToDo: speed up via slurping.
503 getSysMan :: IO String -- How to invoke the system manager
504 -- (parallel system only)
505 getSysMan = readIORef v_Pgm_sysman
509 getUsageMsgPaths :: IO (FilePath,FilePath)
510 -- the filenames of the usage messages (ghc, ghci)
511 getUsageMsgPaths = readIORef v_Path_usages
515 %************************************************************************
517 \subsection{Managing temporary files
519 %************************************************************************
522 GLOBAL_VAR(v_FilesToClean, [], [String] )
526 cleanTempFiles :: DynFlags -> IO ()
527 cleanTempFiles dflags
528 = do fs <- readIORef v_FilesToClean
529 removeTmpFiles dflags fs
530 writeIORef v_FilesToClean []
532 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
533 cleanTempFilesExcept dflags dont_delete
534 = do files <- readIORef v_FilesToClean
535 let (to_keep, to_delete) = partition (`elem` dont_delete) files
536 removeTmpFiles dflags to_delete
537 writeIORef v_FilesToClean to_keep
540 -- find a temporary name that doesn't already exist.
541 newTempName :: DynFlags -> Suffix -> IO FilePath
542 newTempName DynFlags{tmpDir=tmp_dir} extn
543 = do x <- getProcessID
544 findTempName tmp_dir x
546 findTempName tmp_dir x
547 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
548 b <- doesFileExist filename
549 if b then findTempName tmp_dir (x+1)
550 else do consIORef v_FilesToClean filename -- clean it up later
553 addFilesToClean :: [FilePath] -> IO ()
554 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
555 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
557 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
558 removeTmpFiles dflags fs
560 traceCmd dflags "Deleting temp files"
561 ("Deleting: " ++ unwords deletees)
564 verb = verbosity dflags
566 -- Flat out refuse to delete files that are likely to be source input
567 -- files (is there a worse bug than having a compiler delete your source
570 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
573 | null non_deletees = act
575 hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
578 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
580 rm f = removeFile f `IO.catch`
583 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
587 -----------------------------------------------------------------------------
588 -- Running an external program
590 runSomething :: DynFlags
591 -> String -- For -v message
592 -> String -- Command name (possibly a full path)
593 -- assumed already dos-ified
594 -> [Option] -- Arguments
595 -- runSomething will dos-ify them
598 runSomething dflags phase_name pgm args = do
599 let real_args = filter notNull (map showOpt args)
600 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
601 exit_code <- rawSystem pgm real_args
605 -- rawSystem returns (ExitFailure 127) if the exec failed for any
606 -- reason (eg. the program doesn't exist). This is the only clue
607 -- we have, but we need to report something to the user because in
608 -- the case of a missing program there will otherwise be no output
611 throwDyn (InstallationError ("could not execute: " ++ pgm))
612 ExitFailure _other ->
613 throwDyn (PhaseFailed phase_name exit_code)
615 showOpt (FileOption pre f) = pre ++ platformPath f
616 showOpt (Option "") = ""
617 showOpt (Option s) = s
619 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
620 -- a) trace the command (at two levels of verbosity)
621 -- b) don't do it at all if dry-run is set
622 traceCmd dflags phase_name cmd_line action
623 = do { let verb = verbosity dflags
624 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
625 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
629 ; unless (dopt Opt_DryRun dflags) $ do {
632 ; action `IO.catch` handle_exn verb
635 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
636 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
637 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
640 -----------------------------------------------------------------------------
641 Path name construction
644 slash :: String -> String -> String
645 slash s1 s2 = s1 ++ ('/' : s2)
649 %************************************************************************
651 \subsection{Support code}
653 %************************************************************************
656 -----------------------------------------------------------------------------
657 -- Define getBaseDir :: IO (Maybe String)
659 #if defined(mingw32_HOST_OS)
660 getBaseDir :: IO (Maybe String)
661 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
662 -- return the path $(stuff). Note that we drop the "bin/" directory too.
663 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
664 buf <- mallocArray len
665 ret <- getModuleFileName nullPtr buf len
666 if ret == 0 then free buf >> return Nothing
667 else do s <- peekCString buf
669 return (Just (rootDir s))
671 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
673 foreign import stdcall unsafe "GetModuleFileNameA"
674 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
676 getBaseDir :: IO (Maybe String) = do return Nothing
679 #ifdef mingw32_HOST_OS
680 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
681 #elif __GLASGOW_HASKELL__ > 504
682 getProcessID :: IO Int
683 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
685 getProcessID :: IO Int
686 getProcessID = Posix.getProcessID