<commit_before>-----------------------------------------------------------------------------
-- $Id: SysTools.lhs,v 1.50 2001/08/15 14:36:21 rrt Exp $
--
-- (c) The University of Glasgow 2001
--
-- Access to system tools: gcc, cp, rm etc
--
-----------------------------------------------------------------------------

\begin{code}
module SysTools (
	-- Initialisation
	initSysTools,
	setPgm,			-- String -> IO ()
				-- Command-line override
	setDryRun,

	getTopDir,		-- IO String	-- The value of $libdir
	getPackageConfigPath,	-- IO String	-- Where package.conf is

	-- Interface to system tools
	runUnlit, runCpp, runCc, -- [Option] -> IO ()
	runMangle, runSplit,	 -- [Option] -> IO ()
	runAs, runLink,		 -- [Option] -> IO ()
	runMkDLL,
#ifdef ILX
        runIlx2il, runIlasm,     -- [String] -> IO ()
#endif


	touch,			-- String -> String -> IO ()
	copy,			-- String -> String -> String -> IO ()
	unDosifyPath,           -- String -> String
	
	-- Temporary-file management
	setTmpDir,
	newTempName,
	cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
	addFilesToClean,

	-- System interface
	getProcessID,		-- IO Int
	system, 		-- String -> IO ExitCode

	-- Misc
	showGhcUsage,		-- IO ()	Shows usage message and exits
	getSysMan,		-- IO String	Parallel system only
	
	Option(..)

 ) where

import DriverUtil
import Config
import Outputable
import Panic		( progName, GhcException(..) )
import Util		( global )
import CmdLineOpts	( dynFlag, verbosity )

import Exception	( throwDyn, catchAllIO )
import IO
import Directory	( doesFileExist, removeFile )
import IOExts		( IORef, readIORef, writeIORef )
import Monad		( when, unless )
import System		( ExitCode(..), exitWith, getEnv, system )
import CString
import Int
import Addr
    
#include "../includes/config.h"

#ifndef mingw32_TARGET_OS
import qualified Posix
#else
import List		( isPrefixOf )
import MarshalArray
-- use the line below when we can be sure of compiling with GHC >=
-- 5.02, and remove the implementation of rawSystem at the end of this
-- file
import PrelIOBase -- this can be removed when SystemExts is used
import CError     ( throwErrnoIfMinus1 ) -- as can this
-- import SystemExts       ( rawSystem )
#endif

#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)
		


---------------------------------------------
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
---------------------------------------------


%************************************************************************
%*									*
\subsection{Global variables to contain system programs}
%*									*
%************************************************************************

All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
(See remarks under pathnames below)

\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
#ifdef ILX
GLOBAL_VAR(v_Pgm_I,     error "pgm_I",   String)        -- ilx2il
GLOBAL_VAR(v_Pgm_i,     error "pgm_i",   String)        -- ilasm
#endif
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)

GLOBAL_VAR(v_TopDir,	error "TopDir",	String)		-- -B<dir>

-- Parallel system only
GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)	-- system manager

-- ways to get at some of these variables from outside this module
getPackageConfigPath = readIORef v_Path_package_config
getTopDir	     = readIORef v_TopDir
\end{code}


%************************************************************************
%*									*
\subsection{Initialisation}
%*									*
%************************************************************************

\begin{code}
initSysTools :: [String]	-- Command-line arguments starting "-B"

	     -> IO ()		-- Set all the mutable variables above, holding 
				--	(a) the system programs
				--	(b) the package-config file
				--	(c) the GHC usage message


initSysTools minusB_args
  = do  { (am_installed, top_dir) <- findTopDir minusB_args
	; writeIORef v_TopDir top_dir
		-- top_dir
		-- 	for "installed" this is the root of GHC's support files
		--	for "in-place" it is the root of the build tree
		-- NB: top_dir is assumed to be in standard Unix format '/' separated

	; let installed, installed_bin :: FilePath -> FilePath
              installed_bin pgm   =  pgmPath (top_dir `slash` "extra-bin") pgm
	      installed     file  =  pgmPath top_dir file
	      inplace dir   pgm   =  pgmPath (top_dir `slash` dir) pgm

	; let pkgconfig_path
		| am_installed = installed "package.conf"
		| otherwise    = inplace cGHC_DRIVER_DIR "package.conf.inplace"

	      ghc_usage_msg_path
		| am_installed = installed "ghc-usage.txt"
		| otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"

		-- 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

		-- split and mangle are Perl scripts
	      split_script
		| am_installed = installed_bin cGHC_SPLIT
		| otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT

	      mangle_script
		| am_installed = installed_bin cGHC_MANGLER
		| otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER

#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

	-- Check that the package config exists
	; config_exists <- doesFileExist pkgconfig_path
	; when (not config_exists) $
	     throwDyn (InstallationError 
		         ("Can't find package.conf as " ++ pkgconfig_path))

#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
	-- 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.
	; let gcc_path 	| am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
		       	| otherwise    = cGCC
		-- 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 otherwise "\\\" is mangled
		-- later on; although gcc_path is in NATIVE format, gcc can cope
		--	(see comments with declarations of global variables)
		--
		-- The quotes round the -B argument are in case TopDir has spaces in it

	      perl_path | am_installed = installed_bin cGHC_PERL
		        | otherwise    = cGHC_PERL

	-- 'touch' is a GHC util for Windows, and similarly unlit, mangle
	; let touch_path  | am_installed = installed_bin cGHC_TOUCHY
		       	  | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY

	-- 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 ++ "\""

	; 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.
	; let   gcc_path   = cGCC
		touch_path = cGHC_TOUCHY
		mkdll_path = panic "Can't build DLLs on a non-Win32 system"

	-- 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.
	; let split_path  = split_script
	      mangle_path = mangle_script
#endif

	-- cpp is derived from gcc on all platforms
        ; let cpp_path  = gcc_path ++ " -E " ++ cRAWCPP_FLAGS

	-- For all systems, copy and remove are provided by the host
	-- 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

#ifdef ILX
       -- ilx2il and ilasm are specified in Config.hs
       ; let    ilx2il_path = cILX2IL
		ilasm_path  = cILASM
#endif
				       
	-- 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
#ifdef ILX
	; writeIORef v_Pgm_I               ilx2il_path
	; writeIORef v_Pgm_i               ilasm_path
#endif
	; writeIORef v_Pgm_l   	 	   ld_path
	; writeIORef v_Pgm_MkDLL 	   mkdll_path
	; writeIORef v_Pgm_T   	 	   touch_path
	; writeIORef v_Pgm_CP  	 	   cp_path

	; return ()
	}
\end{code}

setPgm is called when a command-line option like
	-pgmLld
is used to override a particular program with a new one

\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
#ifdef ILX
setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
#endif
setPgm pgm	   = unknownFlagErr ("-pgm" ++ pgm)
\end{code}


\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 
--	   where GHC is running (only on Windows)
--
-- 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

findTopDir :: [String]
	  -> IO (Bool, 		-- True <=> am installed, False <=> in-place
	         String)	-- TopDir (in Unix format '/' separated)

findTopDir minusbs
  = do { top_dir <- get_proto
        -- Discover whether we're running in a build tree or in an installation,
	-- by looking for the package configuration file.
       ; am_installed <- doesFileExist (top_dir `slash` "package.conf")

       ; return (am_installed, top_dir)
       }
  where
    -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
    get_proto | not (null minusbs)
	      = return (unDosifyPath (drop 2 (last minusbs)))	-- 2 for "-B"
	      | otherwise	   
	      = do { maybe_exec_dir <- getExecDir -- Get directory of executable
		   ; case maybe_exec_dir of	  -- (only works on Windows; 
						  --  returns Nothing on Unix)
			Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
			Just dir -> return dir
		   }
\end{code}


%************************************************************************
%*									*
\subsection{Command-line options}
n%*									*
%************************************************************************

When invoking external tools as part of the compilation pipeline, we
pass these a sequence of options on the command-line. Rather than
just using a list of Strings, we use a type that allows us to distinguish
between filepaths and 'other stuff'. [The reason being, of course, that
this type gives us a handle on transforming filenames, and filenames only,
to whatever format they're expected to be on a particular platform.]


\begin{code}
data Option
 = FileOption String
 | Option     String
 
showOptions :: [Option] -> String
showOptions ls = unwords (map (quote.showOpt) ls)
 where
   showOpt (FileOption f) = dosifyPath f
   showOpt (Option s)     = s

#if defined(mingw32_TARGET_OS)
   quote "" = ""
   quote s  = "\"" ++ s ++ "\""
#else
   quote = id
#endif

\end{code}


%************************************************************************
%*									*
\subsection{Running an external program}
n%*									*
%************************************************************************


\begin{code}
runUnlit :: [Option] -> IO ()
runUnlit args = do p <- readIORef v_Pgm_L
		   runSomething "Literate pre-processor" p args

runCpp :: [Option] -> IO ()
runCpp args =   do p <- readIORef v_Pgm_P
		   runSomething "C pre-processor" p args

runCc :: [Option] -> IO ()
runCc args =   do p <- readIORef v_Pgm_c
	          runSomething "C Compiler" p args

runMangle :: [Option] -> IO ()
runMangle args = do p <- readIORef v_Pgm_m
		    runSomething "Mangler" p args

runSplit :: [Option] -> IO ()
runSplit args = do p <- readIORef v_Pgm_s
		   runSomething "Splitter" p args

runAs :: [Option] -> IO ()
runAs args = do p <- readIORef v_Pgm_a
		runSomething "Assembler" p args

runLink :: [Option] -> IO ()
runLink args = do p <- readIORef v_Pgm_l
	          runSomething "Linker" p args

#ifdef ILX
runIlx2il :: [String] -> IO ()
runIlx2il args = do p <- readIORef v_Pgm_I
	            runSomething "Ilx2Il" p args

runIlasm :: [String] -> IO ()
runIlasm args = do p <- readIORef v_Pgm_i
	           runSomething "Ilasm" p args
#endif

runMkDLL :: [Option] -> 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 [FileOption arg]

copy :: String -> String -> String -> IO ()
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
\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
		  ; exitWith ExitSuccess }
  where
     dump ""	      = return ()
     dump ('$':'$':s) = hPutStr stderr progName >> dump s
     dump (c:s)	      = hPutChar stderr c >> dump s
\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" 
	     ("Deleting: " ++ unwords fs)
	     (mapM_ rm fs)
  where
    rm f = removeFile f `catchAllIO` 
		(\_ignored -> 
		    when (verb >= 2) $
		      hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
		)

\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
	     -> [Option]	-- Arguments
				--	runSomething will dos-ify them
	     -> IO ()

runSomething phase_name pgm args
 = traceCmd phase_name cmd_line $
   do   {
#ifndef mingw32_TARGET_OS
	  exit_code <- system cmd_line
#else
          exit_code <- rawSystem cmd_line
#endif
	; if exit_code /= ExitSuccess
	  then throwDyn (PhaseFailed phase_name exit_code)
  	  else return ()
	}
  where
    cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
	-- The pgm is already in native format (appropriate dir separators)
#if defined(mingw32_TARGET_OS)
    quote "" = ""
    quote s  = "\"" ++ s ++ "\""
#else
    quote = id
#endif

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}


%************************************************************************
%*									*
\subsection{Path names}
%*									*
%************************************************************************

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'.

\begin{code}
-----------------------------------------------------------------------------
-- Convert filepath into MSDOS form.

dosifyPaths :: [String] -> [String]
-- dosifyPaths does two things
-- a) change '/' to '\'
-- b) remove initial '/cygdrive/'

unDosifyPath :: String -> String
-- Just change '\' to '/'

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



#if defined(mingw32_TARGET_OS)

--------------------- Windows version ------------------
dosifyPaths xs = map dosifyPath xs

unDosifyPath xs = subst '\\' '/' xs

pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm

-- HACK!
dosifyPath "\"/DLL\"" = "\"/DLL\""
dosifyPath "\"/QUIET\"" = "\"/QUIET\""
dosifyPath l@('"':'/':'O':'U':'T':_) = l
-- end of HACK!
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

--------------------- Unix version ---------------------
dosifyPaths  ps  = ps
unDosifyPath xs  = xs
pgmPath dir pgm  = dir ++ '/' : pgm
dosifyPath stuff = stuff
--------------------------------------------------------
#endif

subst a b ls = map (\ x -> if x == a then b else x) ls
\end{code}


-----------------------------------------------------------------------------
   Path name construction

\begin{code}
slash		 :: String -> String -> String
absPath, relPath :: [String] -> String

isSlash '/'   = True
isSlash other = False

relPath [] = ""
relPath xs = foldr1 slash xs

absPath xs = "" `slash` relPath xs

slash s1 s2 = s1 ++ ('/' : s2)
\end{code}


%************************************************************************
%*									*
\subsection{Support code}
%*									*
%************************************************************************

\begin{code}
-----------------------------------------------------------------------------
-- Define	getExecDir     :: IO (Maybe String)

#if defined(mingw32_TARGET_OS)
getExecDir :: IO (Maybe String)
getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
		buf <- mallocArray (fromIntegral len)
		ret <- getModuleFileName nullAddr buf len
		if ret == 0 then return Nothing
		            else do s <- peekCString buf
				    destructArray (fromIntegral len) buf
				    return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))


foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
#else
getExecDir :: IO (Maybe String) = do return Nothing
#endif

#ifdef mingw32_TARGET_OS
foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
#else
getProcessID :: IO Int
getProcessID = Posix.getProcessID
#endif

rawSystem :: String -> IO ExitCode
rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
rawSystem cmd =
  withUnsafeCString cmd $ \s -> do
    status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
    case status of
        0  -> return ExitSuccess
        n  -> return (ExitFailure n)

foreign import ccall "rawSystemCmd" unsafe primRawSystem :: UnsafeCString -> IO Int

\end{code}
<commit_msg>[project @ 2001-08-15 14:59:34 by rrt] Dearie dearie me, we are in a tizz today.<commit_after>-----------------------------------------------------------------------------
-- $Id: SysTools.lhs,v 1.51 2001/08/15 14:59:34 rrt Exp $
--
-- (c) The University of Glasgow 2001
--
-- Access to system tools: gcc, cp, rm etc
--
-----------------------------------------------------------------------------

\begin{code}
module SysTools (
	-- Initialisation
	initSysTools,
	setPgm,			-- String -> IO ()
				-- Command-line override
	setDryRun,

	getTopDir,		-- IO String	-- The value of $libdir
	getPackageConfigPath,	-- IO String	-- Where package.conf is

	-- Interface to system tools
	runUnlit, runCpp, runCc, -- [Option] -> IO ()
	runMangle, runSplit,	 -- [Option] -> IO ()
	runAs, runLink,		 -- [Option] -> IO ()
	runMkDLL,
#ifdef ILX
        runIlx2il, runIlasm,     -- [String] -> IO ()
#endif


	touch,			-- String -> String -> IO ()
	copy,			-- String -> String -> String -> IO ()
	unDosifyPath,           -- String -> String
	
	-- Temporary-file management
	setTmpDir,
	newTempName,
	cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
	addFilesToClean,

	-- System interface
	getProcessID,		-- IO Int
	system, 		-- String -> IO ExitCode

	-- Misc
	showGhcUsage,		-- IO ()	Shows usage message and exits
	getSysMan,		-- IO String	Parallel system only
	
	Option(..)

 ) where

import DriverUtil
import Config
import Outputable
import Panic		( progName, GhcException(..) )
import Util		( global )
import CmdLineOpts	( dynFlag, verbosity )

import Exception	( throwDyn, catchAllIO )
import IO
import Directory	( doesFileExist, removeFile )
import IOExts		( IORef, readIORef, writeIORef )
import Monad		( when, unless )
import System		( ExitCode(..), exitWith, getEnv, system )
import CString
import Int
import Addr
    
#include "../includes/config.h"

#ifndef mingw32_TARGET_OS
import qualified Posix
#else
import List		( isPrefixOf )
import MarshalArray
#endif

-- use the line below when we can be sure of compiling with GHC >=
-- 5.02, and remove the implementation of rawSystem at the end of this
-- file
import PrelIOBase -- this can be removed when SystemExts is used
import CError     ( throwErrnoIfMinus1 ) -- as can this
-- import SystemExts       ( rawSystem )

#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)
		


---------------------------------------------
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
---------------------------------------------


%************************************************************************
%*									*
\subsection{Global variables to contain system programs}
%*									*
%************************************************************************

All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
(See remarks under pathnames below)

\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
#ifdef ILX
GLOBAL_VAR(v_Pgm_I,     error "pgm_I",   String)        -- ilx2il
GLOBAL_VAR(v_Pgm_i,     error "pgm_i",   String)        -- ilasm
#endif
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)

GLOBAL_VAR(v_TopDir,	error "TopDir",	String)		-- -B<dir>

-- Parallel system only
GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)	-- system manager

-- ways to get at some of these variables from outside this module
getPackageConfigPath = readIORef v_Path_package_config
getTopDir	     = readIORef v_TopDir
\end{code}


%************************************************************************
%*									*
\subsection{Initialisation}
%*									*
%************************************************************************

\begin{code}
initSysTools :: [String]	-- Command-line arguments starting "-B"

	     -> IO ()		-- Set all the mutable variables above, holding 
				--	(a) the system programs
				--	(b) the package-config file
				--	(c) the GHC usage message


initSysTools minusB_args
  = do  { (am_installed, top_dir) <- findTopDir minusB_args
	; writeIORef v_TopDir top_dir
		-- top_dir
		-- 	for "installed" this is the root of GHC's support files
		--	for "in-place" it is the root of the build tree
		-- NB: top_dir is assumed to be in standard Unix format '/' separated

	; let installed, installed_bin :: FilePath -> FilePath
              installed_bin pgm   =  pgmPath (top_dir `slash` "extra-bin") pgm
	      installed     file  =  pgmPath top_dir file
	      inplace dir   pgm   =  pgmPath (top_dir `slash` dir) pgm

	; let pkgconfig_path
		| am_installed = installed "package.conf"
		| otherwise    = inplace cGHC_DRIVER_DIR "package.conf.inplace"

	      ghc_usage_msg_path
		| am_installed = installed "ghc-usage.txt"
		| otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"

		-- 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

		-- split and mangle are Perl scripts
	      split_script
		| am_installed = installed_bin cGHC_SPLIT
		| otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT

	      mangle_script
		| am_installed = installed_bin cGHC_MANGLER
		| otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER

#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

	-- Check that the package config exists
	; config_exists <- doesFileExist pkgconfig_path
	; when (not config_exists) $
	     throwDyn (InstallationError 
		         ("Can't find package.conf as " ++ pkgconfig_path))

#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
	-- 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.
	; let gcc_path 	| am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
		       	| otherwise    = cGCC
		-- 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 otherwise "\\\" is mangled
		-- later on; although gcc_path is in NATIVE format, gcc can cope
		--	(see comments with declarations of global variables)
		--
		-- The quotes round the -B argument are in case TopDir has spaces in it

	      perl_path | am_installed = installed_bin cGHC_PERL
		        | otherwise    = cGHC_PERL

	-- 'touch' is a GHC util for Windows, and similarly unlit, mangle
	; let touch_path  | am_installed = installed_bin cGHC_TOUCHY
		       	  | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY

	-- 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 ++ "\""

	; 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.
	; let   gcc_path   = cGCC
		touch_path = cGHC_TOUCHY
		mkdll_path = panic "Can't build DLLs on a non-Win32 system"

	-- 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.
	; let split_path  = split_script
	      mangle_path = mangle_script
#endif

	-- cpp is derived from gcc on all platforms
        ; let cpp_path  = gcc_path ++ " -E " ++ cRAWCPP_FLAGS

	-- For all systems, copy and remove are provided by the host
	-- 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

#ifdef ILX
       -- ilx2il and ilasm are specified in Config.hs
       ; let    ilx2il_path = cILX2IL
		ilasm_path  = cILASM
#endif
				       
	-- 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
#ifdef ILX
	; writeIORef v_Pgm_I               ilx2il_path
	; writeIORef v_Pgm_i               ilasm_path
#endif
	; writeIORef v_Pgm_l   	 	   ld_path
	; writeIORef v_Pgm_MkDLL 	   mkdll_path
	; writeIORef v_Pgm_T   	 	   touch_path
	; writeIORef v_Pgm_CP  	 	   cp_path

	; return ()
	}
\end{code}

setPgm is called when a command-line option like
	-pgmLld
is used to override a particular program with a new one

\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
#ifdef ILX
setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
#endif
setPgm pgm	   = unknownFlagErr ("-pgm" ++ pgm)
\end{code}


\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 
--	   where GHC is running (only on Windows)
--
-- 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

findTopDir :: [String]
	  -> IO (Bool, 		-- True <=> am installed, False <=> in-place
	         String)	-- TopDir (in Unix format '/' separated)

findTopDir minusbs
  = do { top_dir <- get_proto
        -- Discover whether we're running in a build tree or in an installation,
	-- by looking for the package configuration file.
       ; am_installed <- doesFileExist (top_dir `slash` "package.conf")

       ; return (am_installed, top_dir)
       }
  where
    -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
    get_proto | not (null minusbs)
	      = return (unDosifyPath (drop 2 (last minusbs)))	-- 2 for "-B"
	      | otherwise	   
	      = do { maybe_exec_dir <- getExecDir -- Get directory of executable
		   ; case maybe_exec_dir of	  -- (only works on Windows; 
						  --  returns Nothing on Unix)
			Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
			Just dir -> return dir
		   }
\end{code}


%************************************************************************
%*									*
\subsection{Command-line options}
n%*									*
%************************************************************************

When invoking external tools as part of the compilation pipeline, we
pass these a sequence of options on the command-line. Rather than
just using a list of Strings, we use a type that allows us to distinguish
between filepaths and 'other stuff'. [The reason being, of course, that
this type gives us a handle on transforming filenames, and filenames only,
to whatever format they're expected to be on a particular platform.]


\begin{code}
data Option
 = FileOption String
 | Option     String
 
showOptions :: [Option] -> String
showOptions ls = unwords (map (quote.showOpt) ls)
 where
   showOpt (FileOption f) = dosifyPath f
   showOpt (Option s)     = s

#if defined(mingw32_TARGET_OS)
   quote "" = ""
   quote s  = "\"" ++ s ++ "\""
#else
   quote = id
#endif

\end{code}


%************************************************************************
%*									*
\subsection{Running an external program}
n%*									*
%************************************************************************


\begin{code}
runUnlit :: [Option] -> IO ()
runUnlit args = do p <- readIORef v_Pgm_L
		   runSomething "Literate pre-processor" p args

runCpp :: [Option] -> IO ()
runCpp args =   do p <- readIORef v_Pgm_P
		   runSomething "C pre-processor" p args

runCc :: [Option] -> IO ()
runCc args =   do p <- readIORef v_Pgm_c
	          runSomething "C Compiler" p args

runMangle :: [Option] -> IO ()
runMangle args = do p <- readIORef v_Pgm_m
		    runSomething "Mangler" p args

runSplit :: [Option] -> IO ()
runSplit args = do p <- readIORef v_Pgm_s
		   runSomething "Splitter" p args

runAs :: [Option] -> IO ()
runAs args = do p <- readIORef v_Pgm_a
		runSomething "Assembler" p args

runLink :: [Option] -> IO ()
runLink args = do p <- readIORef v_Pgm_l
	          runSomething "Linker" p args

#ifdef ILX
runIlx2il :: [String] -> IO ()
runIlx2il args = do p <- readIORef v_Pgm_I
	            runSomething "Ilx2Il" p args

runIlasm :: [String] -> IO ()
runIlasm args = do p <- readIORef v_Pgm_i
	           runSomething "Ilasm" p args
#endif

runMkDLL :: [Option] -> 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 [FileOption arg]

copy :: String -> String -> String -> IO ()
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
\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
		  ; exitWith ExitSuccess }
  where
     dump ""	      = return ()
     dump ('$':'$':s) = hPutStr stderr progName >> dump s
     dump (c:s)	      = hPutChar stderr c >> dump s
\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" 
	     ("Deleting: " ++ unwords fs)
	     (mapM_ rm fs)
  where
    rm f = removeFile f `catchAllIO` 
		(\_ignored -> 
		    when (verb >= 2) $
		      hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
		)

\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
	     -> [Option]	-- Arguments
				--	runSomething will dos-ify them
	     -> IO ()

runSomething phase_name pgm args
 = traceCmd phase_name cmd_line $
   do   {
#ifndef mingw32_TARGET_OS
	  exit_code <- system cmd_line
#else
          exit_code <- rawSystem cmd_line
#endif
	; if exit_code /= ExitSuccess
	  then throwDyn (PhaseFailed phase_name exit_code)
  	  else return ()
	}
  where
    cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
	-- The pgm is already in native format (appropriate dir separators)
#if defined(mingw32_TARGET_OS)
    quote "" = ""
    quote s  = "\"" ++ s ++ "\""
#else
    quote = id
#endif

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}


%************************************************************************
%*									*
\subsection{Path names}
%*									*
%************************************************************************

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'.

\begin{code}
-----------------------------------------------------------------------------
-- Convert filepath into MSDOS form.

dosifyPaths :: [String] -> [String]
-- dosifyPaths does two things
-- a) change '/' to '\'
-- b) remove initial '/cygdrive/'

unDosifyPath :: String -> String
-- Just change '\' to '/'

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



#if defined(mingw32_TARGET_OS)

--------------------- Windows version ------------------
dosifyPaths xs = map dosifyPath xs

unDosifyPath xs = subst '\\' '/' xs

pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm

-- HACK!
dosifyPath "\"/DLL\"" = "\"/DLL\""
dosifyPath "\"/QUIET\"" = "\"/QUIET\""
dosifyPath l@('"':'/':'O':'U':'T':_) = l
-- end of HACK!
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

--------------------- Unix version ---------------------
dosifyPaths  ps  = ps
unDosifyPath xs  = xs
pgmPath dir pgm  = dir ++ '/' : pgm
dosifyPath stuff = stuff
--------------------------------------------------------
#endif

subst a b ls = map (\ x -> if x == a then b else x) ls
\end{code}


-----------------------------------------------------------------------------
   Path name construction

\begin{code}
slash		 :: String -> String -> String
absPath, relPath :: [String] -> String

isSlash '/'   = True
isSlash other = False

relPath [] = ""
relPath xs = foldr1 slash xs

absPath xs = "" `slash` relPath xs

slash s1 s2 = s1 ++ ('/' : s2)
\end{code}


%************************************************************************
%*									*
\subsection{Support code}
%*									*
%************************************************************************

\begin{code}
-----------------------------------------------------------------------------
-- Define	getExecDir     :: IO (Maybe String)

#if defined(mingw32_TARGET_OS)
getExecDir :: IO (Maybe String)
getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
		buf <- mallocArray (fromIntegral len)
		ret <- getModuleFileName nullAddr buf len
		if ret == 0 then return Nothing
		            else do s <- peekCString buf
				    destructArray (fromIntegral len) buf
				    return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))


foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
#else
getExecDir :: IO (Maybe String) = do return Nothing
#endif

#ifdef mingw32_TARGET_OS
foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
#else
getProcessID :: IO Int
getProcessID = Posix.getProcessID
#endif

rawSystem :: String -> IO ExitCode
rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
rawSystem cmd =
  withUnsafeCString cmd $ \s -> do
    status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
    case status of
        0  -> return ExitSuccess
        n  -> return (ExitFailure n)

foreign import ccall "rawSystemCmd" unsafe primRawSystem :: UnsafeCString -> IO Int

\end{code}

{'fraction_non_alphanumeric': 0.1716325504004953, 'fraction_numerical': 0.003869519792593739, 'mean_word_length': 2.8187661618027335, 'pattern_counts': {'":': 0, '<': 81, '<?xml version=': 0, '>': 161, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4986592', 'n_tokens_mistral': 17867, 'n_tokens_neox': 16167, 'n_words': 5557}