SysTools.lhs 22 KB
 simonpj committed Jun 14, 2001 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 ----------------------------------------------------------------------------- -- Access to system tools: gcc, cp, rm etc -- -- (c) The University of Glasgow 2000 -- ----------------------------------------------------------------------------- \begin{code} module SysTools ( -- Initialisation initSysTools, setPgm, -- String -> IO () -- Command-line override setDryRun, packageConfigPath, -- IO String -- Where package.conf is -- Interface to system tools runUnlit, runCpp, runCc, -- [String] -> IO () runMangle, runSplit, -- [String] -> IO () runAs, runLink, -- [String] -> IO () runMkDLL, touch, -- String -> String -> IO () copy, -- String -> String -> String -> IO ()  rrt committed Jul 17, 2001 27  unDosifyPath, -- String -> String  simonpj committed Jun 14, 2001 28 29 30 31 32 33 34 35 36  -- Temporary-file management setTmpDir, newTempName, cleanTempFiles, cleanTempFilesExcept, removeTmpFiles, addFilesToClean, -- System interface getProcessID, -- IO Int  simonpj committed Jun 15, 2001 37  system, -- String -> IO Int  simonpj committed Jun 14, 2001 38 39 40  -- Misc showGhcUsage, -- IO () Shows usage message and exits  sof committed Jul 11, 2001 41  getSysMan -- IO String Parallel system only  simonpj committed Jun 14, 2001 42 43 44 45 46  ) where import DriverUtil import Config  simonpj committed Jun 14, 2001 47 import Outputable  simonpj committed Jun 14, 2001 48 49 50 51 import Panic ( progName, GhcException(..) ) import Util ( global ) import CmdLineOpts ( dynFlag, verbosity )  simonpj committed Jun 25, 2001 52 import Exception ( throwDyn, catchAllIO )  rrt committed Jun 28, 2001 53 import IO  simonpj committed Jun 14, 2001 54 55 56 import Directory ( doesFileExist, removeFile ) import IOExts ( IORef, readIORef, writeIORef ) import Monad ( when, unless )  sof committed Jul 17, 2001 57 import System ( system, ExitCode(..), exitWith, getEnv )  sof committed Jul 17, 2001 58 59 60 import CString import Int import Addr  rrt committed Jul 10, 2001 61   simonpj committed Jun 14, 2001 62 #include "../includes/config.h"  simonpj committed Jun 14, 2001 63 64 65  #if !defined(mingw32_TARGET_OS) import qualified Posix  rrt committed Jun 14, 2001 66 #else  sof committed Jul 17, 2001 67 68 import List ( isPrefixOf ) import MarshalArray  sof committed Jul 18, 2001 69 #endif  simonpj committed Jun 14, 2001 70   simonpj committed Jun 14, 2001 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 #include "HsVersions.h" \end{code} The configuration story ~~~~~~~~~~~~~~~~~~~~~~~ GHC needs various support files (library packages, RTS etc), plus various auxiliary programs (cp, gcc, etc). It finds these in one of two places: * When running as an *installed program*, GHC finds most of this support stuff in the installed library tree. The path to this tree is passed to GHC via the -B flag, and given to initSysTools . * When running *in-place* in a build tree, GHC finds most of this support stuff in the build tree. The path to the build tree is, again passed to GHC via -B. GHC tells which of the two is the case by seeing whether package.conf is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack). SysTools.initSysProgs figures out exactly where all the auxiliary programs are, and initialises mutable variables to make it easy to call them. To to this, it makes use of definitions in Config.hs, which is a Haskell file containing variables whose value is figured out by the build system. Config.hs contains two sorts of things cGCC, The *names* of the programs cCPP e.g. cGCC = gcc cUNLIT cCPP = gcc -E etc They do *not* include paths cUNLIT_DIR The *path* to the directory containing unlit, split etc cSPLIT_DIR *relative* to the root of the build tree, for use when running *in-place* in a build tree (only)  simonpj committed Jul 04, 2001 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 --------------------------------------------- NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): Another hair-brained scheme for simplifying the current tool location nightmare in GHC: Simon originally suggested using another configuration file along the lines of GCC's specs file - which is fine except that it means adding code to read yet another configuration file. What I didn't notice is that the current package.conf is general enough to do this: Package {name = "tools", import_dirs = [], source_dirs = [], library_dirs = [], hs_libraries = [], extra_libraries = [], include_dirs = [], c_includes = [], package_deps = [], extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.], extra_cc_opts = [], extra_ld_opts = []} Which would have the advantage that we get to collect together in one place the path-specific package stuff with the path-specific tool stuff. End of NOTES ---------------------------------------------  simonpj committed Jun 14, 2001 138 139 140 141 142 143 %************************************************************************ %* * \subsection{Global variables to contain system programs} %* * %************************************************************************  simonpj committed Jun 25, 2001 144 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.  simonpj committed Jun 15, 2001 145 146 (See remarks under pathnames below)  simonpj committed Jun 14, 2001 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 \begin{code} GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp GLOBAL_VAR(v_Path_package_config, error "path_package_config", String) GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String) -- Parallel system only GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager \end{code} %************************************************************************ %* * \subsection{Initialisation} %* * %************************************************************************ \begin{code}  simonpj committed Jun 14, 2001 175 initSysTools :: [String] -- Command-line arguments starting "-B"  simonpj committed Jun 14, 2001 176   simonpj committed Jun 14, 2001 177 178 179 180 181  -> IO String -- Set all the mutable variables above, holding -- (a) the system programs -- (b) the package-config file -- (c) the GHC usage message -- Return TopDir  simonpj committed Jun 14, 2001 182 183   simonpj committed Jun 14, 2001 184 185 186 187 188 initSysTools minusB_args = do { (am_installed, top_dir) <- getTopDir minusB_args -- top_dir -- for "installed" this is the root of GHC's support files -- for "in-place" it is the root of the build tree  simonpj committed Jun 25, 2001 189  -- NB: top_dir is assumed to be in standard Unix format '/' separated  simonpj committed Jun 14, 2001 190   sewardj committed Jul 05, 2001 191  ; let installed, installed_bin :: FilePath -> FilePath  rrt committed Jul 16, 2001 192  installed_bin pgm = pgmPath (top_dir slash "extra-bin") pgm  simonpj committed Jun 25, 2001 193 194  installed file = pgmPath top_dir file inplace dir pgm = pgmPath (top_dir slash dir) pgm  simonpj committed Jun 14, 2001 195   simonmar committed Jun 15, 2001 196 197 198  ; let pkgconfig_path | am_installed = installed "package.conf" | otherwise = inplace cGHC_DRIVER_DIR "package.conf.inplace"  simonpj committed Jun 14, 2001 199   simonmar committed Jun 15, 2001 200 201 202  ghc_usage_msg_path | am_installed = installed "ghc-usage.txt" | otherwise = inplace cGHC_DRIVER_DIR "ghc-usage.txt"  simonpj committed Jun 14, 2001 203   simonmar committed Jun 15, 2001 204 205 206 207 208  -- For all systems, unlit, split, mangle are GHC utilities -- architecture-specific stuff is done when building Config.hs unlit_path | am_installed = installed_bin cGHC_UNLIT | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT  simonpj committed Jun 14, 2001 209 210  -- split and mangle are Perl scripts  simonmar committed Jun 15, 2001 211 212 213  split_script | am_installed = installed_bin cGHC_SPLIT | otherwise = inplace cGHC_SPLIT_DIR cGHC_SPLIT  simonpj committed Jun 14, 2001 214   simonmar committed Jun 15, 2001 215 216 217 218  mangle_script | am_installed = installed_bin cGHC_MANGLER | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER  simonmar committed Jul 13, 2001 219 220 221 222 223 224 225 226 #ifndef mingw32_TARGET_OS -- check whether TMPDIR is set in the environment ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set setTmpDir dir return () ) #endif  simonmar committed Jun 15, 2001 227 228 229 230  -- Check that the package config exists ; config_exists <- doesFileExist pkgconfig_path ; when (not config_exists)$ throwDyn (InstallationError  rrt committed Jun 28, 2001 231  ("Can't find package.conf as " ++ pkgconfig_path))  simonpj committed Jun 14, 2001 232   simonpj committed Jun 14, 2001 233 234 235 236 237 238 #if defined(mingw32_TARGET_OS) -- WINDOWS-SPECIFIC STUFF -- On Windows, gcc and friends are distributed with GHC, -- so when "installed" we look in TopDir/bin -- When "in-place" we look wherever the build-time configure -- script found them  sewardj committed Jul 05, 2001 239 240 241 242 243 244 245 246  -- When "install" we tell gcc where its specs file + exes are (-B) -- and also some places to pick up include files. We need -- to be careful to put all necessary exes in the -B place -- (as, ld, cc1, etc) since if they don't get found there, gcc -- then tries to run unadorned "as", "ld", etc, and will -- pick up whatever happens to be lying around in the path, -- possibly including those from a cygwin install on the target, -- which is exactly what we're trying to avoid.  simonpj committed Jul 17, 2001 247  ; let gcc_path | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib\\\"")  simonpj committed Jun 14, 2001 248  | otherwise = cGCC  simonpj committed Jul 17, 2001 249 250 251 252 253 254 255 256  -- The trailing "\\" is absolutely essential; gcc seems -- to construct file names simply by concatenating to this -- -B path with no extra slash. -- We use "\\" rather than "/" because gcc_path is in NATIVE format -- (see comments with declarations of global variables) -- -- The quotes round the -B argument are in case TopDir has spaces in it  sewardj committed Jul 05, 2001 257  perl_path | am_installed = installed_bin cGHC_PERL  simonpj committed Jun 14, 2001 258 259 260  | otherwise = cGHC_PERL -- 'touch' is a GHC util for Windows, and similarly unlit, mangle  sewardj committed Jul 05, 2001 261  ; let touch_path | am_installed = installed_bin cGHC_TOUCHY  simonpj committed Jun 14, 2001 262 263  | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY  simonpj committed Jun 14, 2001 264 265 266 267 268  -- On Win32 we don't want to rely on #!/bin/perl, so we prepend -- a call to Perl to get the invocation of split and mangle ; let split_path = perl_path ++ " " ++ split_script mangle_path = perl_path ++ " " ++ mangle_script  simonpj committed Jun 14, 2001 269 270 271 272 273 274  ; let mkdll_path = cMKDLL #else -- UNIX-SPECIFIC STUFF -- On Unix, the "standard" tools are assumed to be -- in the same place whether we are running "in-place" or "installed" -- That place is wherever the build-time configure script found them.  sewardj committed Jul 05, 2001 275  ; let gcc_path = cGCC  simonpj committed Jun 14, 2001 276  touch_path = cGHC_TOUCHY  rrt committed Jun 22, 2001 277  mkdll_path = panic "Can't build DLLs on a non-Win32 system"  simonpj committed Jun 14, 2001 278   simonmar committed Jun 15, 2001 279 280 281 282  -- On Unix, scripts are invoked using the '#!' method. Binary -- installations of GHC on Unix place the correct line on the front -- of the script at installation time, so we don't want to wire-in -- our knowledge of $(PERL) on the host system here.  simonpj committed Jun 14, 2001 283 284 285  ; let split_path = split_script mangle_path = mangle_script #endif  simonpj committed Jun 14, 2001 286   sewardj committed Jul 05, 2001 287 288 289  -- cpp is derived from gcc on all platforms ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS  rrt committed Jun 28, 2001 290  -- For all systems, copy and remove are provided by the host  simonpj committed Jun 14, 2001 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317  -- system; architecture-specific stuff is done when building Config.hs ; let cp_path = cGHC_CP -- Other things being equal, as and ld are simply gcc ; let as_path = gcc_path ld_path = gcc_path -- Initialise the global vars ; writeIORef v_Path_package_config pkgconfig_path ; writeIORef v_Path_usage ghc_usage_msg_path ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan") -- Hans: this isn't right in general, but you can -- elaborate it in the same way as the others ; writeIORef v_Pgm_L unlit_path ; writeIORef v_Pgm_P cpp_path ; writeIORef v_Pgm_c gcc_path ; writeIORef v_Pgm_m mangle_path ; writeIORef v_Pgm_s split_path ; writeIORef v_Pgm_a as_path ; writeIORef v_Pgm_l ld_path ; writeIORef v_Pgm_MkDLL mkdll_path ; writeIORef v_Pgm_T touch_path ; writeIORef v_Pgm_CP cp_path  simonpj committed Jun 14, 2001 318  ; return top_dir  simonpj committed Jun 14, 2001 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340  } \end{code} setPgm is called when a command-line option like -pgmLld is used to override a particular program with a new onw \begin{code} setPgm :: String -> IO () -- The string is the flag, minus the '-pgm' prefix -- So the first character says which program to override setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm setPgm pgm = unknownFlagErr ("-pgm" ++ pgm) \end{code}  simonpj committed Jun 14, 2001 341 342 343 344 345 346 347 348 349 \begin{code} -- Find TopDir -- for "installed" this is the root of GHC's support files -- for "in-place" it is the root of the build tree -- -- Plan of action: -- 1. Set proto_top_dir -- a) look for (the last) -B flag, and use it -- b) if there are no -B flags, get the directory  rrt committed Jun 28, 2001 350 -- where GHC is running (only on Windows)  simonpj committed Jun 14, 2001 351 352 353 354 355 356 357 358 359 360 361 362 -- -- 2. If package.conf exists in proto_top_dir, we are running -- installed; and TopDir = proto_top_dir -- -- 3. Otherwise we are running in-place, so -- proto_top_dir will be /...stuff.../ghc/compiler -- Set TopDir to /...stuff..., which is the root of the build tree -- -- This is very gruesome indeed getTopDir :: [String] -> IO (Bool, -- True <=> am installed, False <=> in-place  simonpj committed Jun 25, 2001 363  String) -- TopDir (in Unix format '/' separated)  simonpj committed Jun 14, 2001 364 365  getTopDir minusbs  rrt committed Jun 28, 2001 366 367  = do { top_dir <- get_proto -- Discover whether we're running in a build tree or in an installation,  simonpj committed Jun 14, 2001 368  -- by looking for the package configuration file.  rrt committed Jun 28, 2001 369  ; am_installed <- doesFileExist (top_dir slash "package.conf")  simonpj committed Jun 14, 2001 370   rrt committed Jun 28, 2001 371  ; return (am_installed, top_dir)  simonpj committed Jun 14, 2001 372 373  } where  rrt committed Jul 17, 2001 374  -- get_proto returns a Unix-format path (relying on getExecDir to do so too)  rrt committed Jun 28, 2001 375 376  get_proto | not (null minusbs) = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"  simonpj committed Jun 14, 2001 377  | otherwise  simonmar committed Jun 15, 2001 378  = do { maybe_exec_dir <- getExecDir -- Get directory of executable  simonpj committed Jun 15, 2001 379 380 381  ; case maybe_exec_dir of -- (only works on Windows; -- returns Nothing on Unix) Nothing -> throwDyn (InstallationError "missing -B option")  rrt committed Jul 17, 2001 382  Just dir -> return dir  simonmar committed Jun 15, 2001 383  }  simonpj committed Jun 14, 2001 384 385 386 \end{code}  simonpj committed Jun 14, 2001 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 %************************************************************************ %* * \subsection{Running an external program} n%* * %************************************************************************ \begin{code} runUnlit :: [String] -> IO () runUnlit args = do p <- readIORef v_Pgm_L runSomething "Literate pre-processor" p args runCpp :: [String] -> IO () runCpp args = do p <- readIORef v_Pgm_P runSomething "C pre-processor" p args runCc :: [String] -> IO () runCc args = do p <- readIORef v_Pgm_c runSomething "C Compiler" p args runMangle :: [String] -> IO () runMangle args = do p <- readIORef v_Pgm_m runSomething "Mangler" p args runSplit :: [String] -> IO () runSplit args = do p <- readIORef v_Pgm_s runSomething "Splitter" p args runAs :: [String] -> IO () runAs args = do p <- readIORef v_Pgm_a runSomething "Assembler" p args runLink :: [String] -> IO () runLink args = do p <- readIORef v_Pgm_l runSomething "Linker" p args runMkDLL :: [String] -> IO () runMkDLL args = do p <- readIORef v_Pgm_MkDLL runSomething "Make DLL" p args touch :: String -> String -> IO () touch purpose arg = do p <- readIORef v_Pgm_T runSomething purpose p [arg] copy :: String -> String -> String -> IO ()  simonmar committed Jun 29, 2001 432 433 434 435 436 437 438 439 440 copy purpose from to = do verb <- dynFlag verbosity when (verb >= 2)$ hPutStrLn stderr ("*** " ++ purpose) h <- openFile to WriteMode ls <- readFile from -- inefficient, but it'll do for now. -- ToDo: speed up via slurping. hPutStr h ls hClose h  simonpj committed Jun 14, 2001 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 \end{code} \begin{code} getSysMan :: IO String -- How to invoke the system manager -- (parallel system only) getSysMan = readIORef v_Pgm_sysman \end{code} %************************************************************************ %* * \subsection{GHC Usage message} %* * %************************************************************************ Show the usage message and exit \begin{code} showGhcUsage = do { usage_path <- readIORef v_Path_usage ; usage <- readFile usage_path ; dump usage  rrt committed Jun 22, 2001 461  ; exitWith ExitSuccess }  simonpj committed Jun 14, 2001 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518  where dump "" = return () dump ('$':'$':s) = hPutStr stderr progName >> dump s dump (c:s) = hPutChar stderr c >> dump s packageConfigPath = readIORef v_Path_package_config \end{code} %************************************************************************ %* * \subsection{Managing temporary files %* * %************************************************************************ \begin{code} GLOBAL_VAR(v_FilesToClean, [], [String] ) GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String ) -- v_TmpDir has no closing '/' \end{code} \begin{code} setTmpDir dir = writeIORef v_TmpDir dir cleanTempFiles :: Int -> IO () cleanTempFiles verb = do fs <- readIORef v_FilesToClean removeTmpFiles verb fs cleanTempFilesExcept :: Int -> [FilePath] -> IO () cleanTempFilesExcept verb dont_delete = do fs <- readIORef v_FilesToClean let leftovers = filter (notElem dont_delete) fs removeTmpFiles verb leftovers writeIORef v_FilesToClean dont_delete -- find a temporary name that doesn't already exist. newTempName :: Suffix -> IO FilePath newTempName extn = do x <- getProcessID tmp_dir <- readIORef v_TmpDir findTempName tmp_dir x where findTempName tmp_dir x = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn b <- doesFileExist filename if b then findTempName tmp_dir (x+1) else do add v_FilesToClean filename -- clean it up later return filename addFilesToClean :: [FilePath] -> IO () -- May include wildcards [used by DriverPipeline.run_phase SplitMangle] addFilesToClean files = mapM_ (add v_FilesToClean) files removeTmpFiles :: Int -> [FilePath] -> IO () removeTmpFiles verb fs = traceCmd "Deleting temp files"  sof committed Jun 15, 2001 519  ("Deleting: " ++ unwords fs)  simonpj committed Jun 14, 2001 520 521  (mapM_ rm fs) where  simonmar committed Jun 29, 2001 522 523 524 525 526  rm f = removeFile f catchAllIO (\_ignored -> when (verb >= 2) $hPutStrLn stderr ("Warning: deleting non-existent " ++ f) )  simonpj committed Jun 14, 2001 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549  \end{code} %************************************************************************ %* * \subsection{Running a program} %* * %************************************************************************ \begin{code} GLOBAL_VAR(v_Dry_run, False, Bool) setDryRun :: IO () setDryRun = writeIORef v_Dry_run True ----------------------------------------------------------------------------- -- Running an external program runSomething :: String -- For -v message -> String -- Command name (possibly a full path) -- assumed already dos-ified -> [String] -- Arguments  simonpj committed Jun 25, 2001 550  -- runSomething will dos-ify them  simonpj committed Jun 14, 2001 551 552 553 554  -> IO () runSomething phase_name pgm args = traceCmd phase_name cmd_line$  simonpj committed Jun 15, 2001 555  do { exit_code <- system cmd_line  simonpj committed Jun 14, 2001 556 557 558 559 560  ; if exit_code /= ExitSuccess then throwDyn (PhaseFailed phase_name exit_code) else return () } where  rrt committed Jul 17, 2001 561  cmd_line = unwords (pgm : dosifyPaths (map quote args))  rrt committed Jun 28, 2001 562  -- The pgm is already in native format (appropriate dir separators)  sof committed Jul 17, 2001 563 #if defined(mingw32_TARGET_OS)  rrt committed Jul 17, 2001 564 565  quote "" = "" quote s = "\"" ++ s ++ "\""  sof committed Jul 17, 2001 566 567 568 #else quote = id #endif  simonpj committed Jun 14, 2001 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594  traceCmd :: String -> String -> IO () -> IO () -- a) trace the command (at two levels of verbosity) -- b) don't do it at all if dry-run is set traceCmd phase_name cmd_line action = do { verb <- dynFlag verbosity ; when (verb >= 2) $hPutStrLn stderr ("*** " ++ phase_name) ; when (verb >= 3)$ hPutStrLn stderr cmd_line ; hFlush stderr -- Test for -n flag ; n <- readIORef v_Dry_run ; unless n \$ do { -- And run it! ; action catchAllIO handle_exn verb }} where handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n") ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line)) ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) } \end{code} %************************************************************************ %* *  simonpj committed Jun 15, 2001 595 \subsection{Path names}  simonpj committed Jun 14, 2001 596 597 598 %* * %************************************************************************  simonpj committed Jun 15, 2001 599 600 601 602 603 604 605 606 We maintain path names in Unix form ('/'-separated) right until the last moment. On Windows we dos-ify them just before passing them to the Windows command. The alternative, of using '/' consistently on Unix and '\' on Windows, proved quite awkward. There were a lot more calls to dosifyPath, and even on Windows we might invoke a unix-like utility (eg 'sh'), which interpreted a command line 'foo\baz' as 'foobaz'.  simonpj committed Jun 14, 2001 607 608 609 610 611  \begin{code} ----------------------------------------------------------------------------- -- Convert filepath into MSDOS form.  simonpj committed Jun 15, 2001 612 dosifyPaths :: [String] -> [String]  simonpj committed Jun 25, 2001 613 -- dosifyPaths does two things  simonpj committed Jun 14, 2001 614 615 616 -- a) change '/' to '\' -- b) remove initial '/cygdrive/'  simonpj committed Jun 15, 2001 617 618 619 unDosifyPath :: String -> String -- Just change '\' to '/'  simonpj committed Jun 25, 2001 620 621 622 623 624 625 626 pgmPath :: String -- Directory string in Unix format -> String -- Program name with no directory separators -- (e.g. copy /y) -> String -- Program invocation string in native format  simonpj committed Jun 14, 2001 627 #if defined(mingw32_TARGET_OS)  simonpj committed Jun 15, 2001 628 629  --------------------- Windows version ------------------  simonpj committed Jun 14, 2001 630 631 dosifyPaths xs = map dosifyPath xs  rrt committed Jul 11, 2001 632 633 unDosifyPath xs = subst '\\' '/' xs  simonpj committed Jun 25, 2001 634 635 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm  simonpj committed Jun 14, 2001 636 637 638 639 640 641 642 643 644 645 646 647 dosifyPath stuff = subst '/' '\\' real_stuff where -- fully convince myself that /cygdrive/ prefixes cannot -- really appear here. cygdrive_prefix = "/cygdrive/" real_stuff | cygdrive_prefix isPrefixOf stuff = drop (length cygdrive_prefix) stuff | otherwise = stuff #else  simonpj committed Jun 15, 2001 648 649  --------------------- Unix version ---------------------  sof committed Jun 15, 2001 650 dosifyPaths ps = ps  rrt committed Jul 11, 2001 651 unDosifyPath xs = xs  simonpj committed Jun 25, 2001 652 pgmPath dir pgm = dir ++ '/' : pgm  simonpj committed Jun 15, 2001 653 --------------------------------------------------------  simonpj committed Jun 14, 2001 654 655 #endif  simonpj committed Jun 15, 2001 656 657 658 659 subst a b ls = map (\ x -> if x == a then b else x) ls \end{code}  simonpj committed Jun 14, 2001 660 -----------------------------------------------------------------------------  simonpj committed Jun 15, 2001 661  Path name construction  simonpj committed Jun 14, 2001 662   simonpj committed Jun 15, 2001 663 \begin{code}  simonpj committed Jun 14, 2001 664 665 666 slash :: String -> String -> String absPath, relPath :: [String] -> String  simonpj committed Jun 14, 2001 667 668 isSlash '/' = True isSlash other = False  simonpj committed Jun 14, 2001 669 670 671 672 673 674  relPath [] = "" relPath xs = foldr1 slash xs absPath xs = "" slash relPath xs  simonpj committed Jun 14, 2001 675 slash s1 s2 = s1 ++ ('/' : s2)  simonpj committed Jun 15, 2001 676 677 \end{code}  simonpj committed Jun 14, 2001 678   simonpj committed Jun 15, 2001 679 680 681 682 683 684 685 %************************************************************************ %* * \subsection{Support code} %* * %************************************************************************ \begin{code}  simonpj committed Jun 14, 2001 686 -----------------------------------------------------------------------------  rrt committed Jul 10, 2001 687 -- Define getExecDir :: IO (Maybe String)  simonpj committed Jun 14, 2001 688   rrt committed Jul 10, 2001 689 #if defined(mingw32_TARGET_OS)  rrt committed Jun 25, 2001 690 getExecDir :: IO (Maybe String)  sof committed Jul 17, 2001 691 getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.  sof committed Jul 17, 2001 692 693 694 695 696  buf <- mallocArray (fromIntegral len) ret <- getModuleFileName nullAddr buf len if ret == 0 then return Nothing else do s <- peekCString buf destructArray (fromIntegral len) buf  rrt committed Jul 18, 2001 697  return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))  sof committed Jul 17, 2001 698   sof committed Jul 17, 2001 699 700  foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32  rrt committed Jun 25, 2001 701 #else  rrt committed Jul 10, 2001 702 getExecDir :: IO (Maybe String) = do return Nothing  rrt committed Jun 25, 2001 703 #endif  rrt committed Jul 10, 2001 704 705 706  #ifdef mingw32_TARGET_OS foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows  simonpj committed Jun 14, 2001 707 708 709 710 711 #else getProcessID :: IO Int getProcessID = Posix.getProcessID #endif \end{code}