-- System interface
getProcessID, -- IO Int
- System.system, -- String -> IO Int -- System.system
+ system, -- String -> IO Int
-- Misc
showGhcUsage, -- IO () Shows usage message and exits
getSysMan, -- IO String Parallel system only
+ dosifyPath, -- String -> String
runSomething -- ToDo: make private
) where
import CmdLineOpts ( dynFlag, verbosity )
import List ( intersperse, isPrefixOf )
-import Exception ( throwDyn, catchAllIO )
-import IO ( openFile, hClose, IOMode(..),
- hPutStr, hPutChar, hPutStrLn, hFlush, stderr
- )
+import Exception ( throw, throwDyn, catchAllIO )
+import IO ( hPutStr, hPutChar, hPutStrLn, hFlush, stderr )
+import IO ( openFile, IOMode(..), hClose ) -- For temp "system"
import Directory ( doesFileExist, removeFile )
import IOExts ( IORef, readIORef, writeIORef )
import Monad ( when, unless )
#if !defined(mingw32_TARGET_OS)
import qualified Posix
+#else
+import Addr ( nullAddr )
#endif
#include "HsVersions.h"
GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
-GLOBAL_VAR(v_Pgm_PERL, error "pgm_PERL", String) -- perl
GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
-- for "installed" this is the root of GHC's support files
-- for "in-place" it is the root of the build tree
- ; let installed pgm = top_dir `slash` "extra-bin" `slash` pgm
- inplace dir pgm = top_dir `slash` dir `slash` pgm
-
- ; let pkgconfig_path | am_installed = top_dir `slash` "package.conf"
- | otherwise = top_dir `slash` cGHC_DRIVER_DIR `slash` "package.conf.inplace"
-
- -- Check that the in-place package config exists if
- -- the installed one does not (we need at least one!)
- ; config_exists <- doesFileExist pkgconfig_path
- ; if config_exists then return ()
- else throwDyn (InstallationError
- ("Can't find package.conf in " ++ pkgconfig_path))
+ ; let installed_bin pgm = top_dir `slash` "bin" `slash` pgm
+ installed file = top_dir `slash` file
+ inplace dir pgm = top_dir `slash` dosifyPath dir `slash` pgm
- -- The GHC usage help message is found similarly to the package configuration
- ; let ghc_usage_msg_path | am_installed = installed "ghc-usage.txt"
- | otherwise = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
+ ; 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
- ; let unlit_path | am_installed = installed cGHC_UNLIT
- | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT
+ -- 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 cGHC_SPLIT
- | otherwise = inplace cGHC_SPLIT_DIR cGHC_SPLIT
- mangle_script | am_installed = installed cGHC_MANGLER
- | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER
+ 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
+ -- Check that the package config exists
+ ; config_exists <- doesFileExist pkgconfig_path
+ ; when (not config_exists) $
+ throwDyn (InstallationError
+ ("Can't find package.conf in " ++ pkgconfig_path))
#if defined(mingw32_TARGET_OS)
-- WINDOWS-SPECIFIC STUFF
; let cpp_path = cRAWCPP
gcc_path = cGCC
touch_path = cGHC_TOUCHY
- perl_path = cGHC_PERL
mkdll_path = panic "Cant build DLLs on a non-Win32 system"
- -- On Unix, for some historical reason, we do an install-time
- -- configure to find Perl, and slam that on the front of
- -- the installed script; so we can invoke them directly
- -- (not via perl)
- -- a call to Perl to get the invocation of split and mangle
+ -- 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
; writeIORef v_Pgm_MkDLL mkdll_path
; writeIORef v_Pgm_T touch_path
; writeIORef v_Pgm_CP cp_path
- ; writeIORef v_Pgm_PERL perl_path
; return top_dir
}
get_proto | not (null minusbs)
= return (dosifyPath (drop 2 (last minusbs)))
| otherwise
- = do { maybe_exec_dir <- getExecDir -- Get directory of executable
- ; case maybe_exec_dir of -- (only works on Windows)
- Nothing -> throwDyn (InstallationError ("missing -B<dir> option"))
- Just dir -> return dir }
+ = do { maybe_exec_dir <- getExecDir -- Get directory of executable
+ ; case maybe_exec_dir of -- (only works on Windows)
+ Nothing -> throwDyn (InstallationError
+ "missing -B<dir> option")
+ Just dir -> return dir
+ }
remove_suffix dir -- "/...stuff.../ghc/compiler" --> "/...stuff..."
= ASSERT2( not (null p1) &&
p1 = dropWhile (not . isSlash) (reverse dir)
p2 = dropWhile (not . isSlash) (tail p1) -- head is '/'
top_dir = reverse (tail p2) -- head is '/'
-
-getExecDir = return Nothing
\end{code}
runSomething phase_name pgm args
= traceCmd phase_name cmd_line $
- do { exit_code <- System.system cmd_line
+ do { exit_code <- system cmd_line
; if exit_code /= ExitSuccess
then throwDyn (PhaseFailed phase_name exit_code)
else return ()
#endif
-----------------------------------------------------------------------------
--- Convert filepath into MSDOS form.
---
-- Define myGetProcessId :: IO Int
+-- getExecDir :: IO (Maybe String)
#ifdef mingw32_TARGET_OS
-foreign import "_getpid" getProcessID :: IO Int
+foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
+
+getExecDir :: IO (Maybe String)
+getExecDir = return Nothing
+{-
+foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> CString -> IO Int32
+getExecDir = do len <- getCurrentDirectory 0 nullAddr
+ buf <- mallocArray (fromIntegral len)
+ ret <- getCurrentDirectory len buf
+ if ret == 0 then return Nothing
+ else do s <- peekCString buf
+ destructArray (fromIntegral len) buf
+ return (Just s)
+-}
#else
getProcessID :: IO Int
getProcessID = Posix.getProcessID
+getExecDir :: IO (Maybe String) = do return Nothing
#endif
\end{code}
+
+%************************************************************************
+%* *
+\subsection{System}
+%* *
+%************************************************************************
+
+In GHC prior to 5.01 (or so), on Windows, the implementation
+of "system" in the library System.system does not work for very
+long command lines. But GHC may need to make a system call with
+a very long command line, notably when it links itself during
+bootstrapping.
+
+Solution: when compiling SysTools for Windows, using GHC prior
+to 5.01, write the command to a file and use "sh" (not cmd.exe)
+to execute it. Such GHCs require "sh" on the path, but once
+bootstrapped this problem goes away.
+
+ToDo: remove when compiling with GHC < 5 is not relevant any more
+
+\begin{code}
+system cmd
+
+#if !defined(mingw32_TARGET_OS) || __GLASGOW_HASKELL__ > 501
+ -- The usual case
+ = System.system cmd
+
+#else -- The Hackoid case
+ = do pid <- getProcessID
+ tmp_dir <- readIORef v_TmpDir
+ let tmp = tmp_dir++"/sh"++show pid
+ h <- openFile tmp WriteMode
+ hPutStrLn h cmd
+ hClose h
+ exit_code <- System.system ("sh - " ++ tmp) `catchAllIO`
+ (\exn -> removeFile tmp >> throw exn)
+ removeFile tmp
+ return exit_code
+#endif
+\end{code}
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff