From: simonpj Date: Thu, 14 Jun 2001 15:42:35 +0000 (+0000) Subject: [project @ 2001-06-14 15:42:35 by simonpj] X-Git-Tag: Approximately_9120_patches~1756 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=54f9adfa25afe299b7e86f6836b49647c1e3a811;hp=6e694be02105c735ab346b6cb94bd1d8f03e5f20;p=ghc-hetmet.git [project @ 2001-06-14 15:42:35 by simonpj] Windows wibbles --- diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 2e1a166..971a83d 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.157 2001/06/14 14:14:53 simonmar Exp $ +# $Id: Makefile,v 1.158 2001/06/14 15:42:35 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -48,7 +48,7 @@ $(CONFIG_HS) : $(FPTOOLS_TOP)/mk/config.mk Makefile @echo "cLeadingUnderscore = \"$(LeadingUnderscore)\"" >> $(CONFIG_HS) @echo "cRAWCPP = \"$(GHC_RAWCPP)\"" >> $(CONFIG_HS) @echo "cGCC = \"$(WhatGccIsCalled)\"" >> $(CONFIG_HS) - @echo "cMkDLL = \"$(BLD_DLL)\"" >> $(CONFIG_HS) + @echo "cMKDLL = \"$(BLD_DLL)\"" >> $(CONFIG_HS) @echo "cGHC_DRIVER_DIR = \"$(GHC_DRIVER_DIR)\"" >> $(CONFIG_HS) @echo "cGHC_TOUCHY = \"$(GHC_TOUCHY)\"" >> $(CONFIG_HS) @echo "cGHC_TOUCHY_DIR = \"$(GHC_TOUCHY)\"" >> $(CONFIG_HS) @@ -318,11 +318,11 @@ all :: ghc-inplace ghc-inplace : $(HS_PROG) @$(RM) $@ echo '#!/bin/sh' >>$@ - echo exec $(FPTOOLS_TOP_ABS_UNIX)/ghc/compiler/$(HS_PROG) -B$(FPTOOLS_TOP_ABS) '"$$@"' >>$@ + echo exec $(FPTOOLS_TOP_ABS_UNIX)/ghc/compiler/$(HS_PROG) -B$(FPTOOLS_TOP_ABS)/ghc/compiler '"$$@"' >>$@ chmod 755 $@ ifeq "$(TARGETPLATFORM) and $(MinimalUnixDeps)" "i386-unknown-mingw32 and YES" @$(RM) $@.bat - echo "@"$(subst /,\\,$(FPTOOLS_TOP_ABS)/ghc/compiler/$(HS_PROG)) "-B$(FPTOOLS_TOP_ABS) %*" >$@.bat + echo "@"$(subst /,\\,$(FPTOOLS_TOP_ABS)/ghc/compiler/$(HS_PROG)) "-B$(FPTOOLS_TOP_ABS)/ghc/compiler %*" >$@.bat chmod 755 $@.bat endif diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index 89e8ef4..69840a3 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.9 2001/05/08 10:58:48 simonmar Exp $ +-- $Id: DriverPhases.hs,v 1.10 2001/06/14 15:42:35 simonpj Exp $ -- -- GHC Driver -- @@ -18,6 +18,8 @@ module DriverPhases ( cish_file, cish_suffix ) where +#include "../includes/config.h" + import DriverUtil ----------------------------------------------------------------------------- diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 57f7d3d..b0cbedd 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.70 2001/06/14 12:50:06 simonpj Exp $ +-- $Id: Main.hs,v 1.71 2001/06/14 15:42:35 simonpj Exp $ -- -- GHC Driver program -- @@ -55,13 +55,13 @@ import Panic ( GhcException(..), panic ) -- Standard Haskell libraries import IO -import Concurrent ( myThreadId, throwTo ) import Directory ( doesFileExist ) import IOExts ( readIORef, writeIORef ) -import Exception ( throwTo, throwDyn, Exception(DynException) ) +import Exception ( throwDyn, Exception(DynException) ) import System ( getArgs, exitWith, ExitCode(..) ) #ifndef mingw32_TARGET_OS +import Concurrent ( myThreadId, throwTo ) import Posix ( Handler(Catch), installHandler, sigINT, sigQUIT ) import Dynamic ( toDyn ) #endif @@ -126,20 +126,17 @@ main = -- signals. -- install signal handlers - main_thread <- myThreadId #ifndef mingw32_TARGET_OS + main_thread <- myThreadId let sig_handler = Catch (throwTo main_thread (DynException (toDyn Interrupted))) installHandler sigQUIT sig_handler Nothing installHandler sigINT sig_handler Nothing #endif - argv <- getArgs - - -- grab any -B options from the command line first - let (top_dir, argv') = getTopDir argv - - initSysTools top_dir + argv <- getArgs + let (minusB_args, argv') = partition (prefixMatch "-B") argv + top_dir <- initSysTools minusB_args -- read the package configuration conf_file <- packageConfigPath @@ -298,15 +295,6 @@ main = when (mode == DoMkDLL) (doMkDLL o_files) } - -- grab the last -B option on the command line, and - -- set topDir to its value. -getTopDir :: [String] -> (String, [String]) -getTopDir args - | null minusbs = throwDyn (InstallationError ("missing -B option")) - | otherwise = (drop 2 (last minusbs), others) - where - (minusbs, others) = partition (prefixMatch "-B") args - -- replace the string "$libdir" at the beginning of a path with the -- current libdir (obtained from the -B option). diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index 4e8c0bb..945ae44 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -33,7 +33,7 @@ module SysTools ( -- System interface getProcessID, -- IO Int - system, -- String -> IO Int -- System.system + System.system, -- String -> IO Int -- System.system -- Misc showGhcUsage, -- IO () Shows usage message and exits @@ -44,22 +44,28 @@ module SysTools ( import DriverUtil import Config -import Outputable ( panic ) +import Outputable import Panic ( progName, GhcException(..) ) import Util ( global ) import CmdLineOpts ( dynFlag, verbosity ) -import List ( intersperse ) +import List ( intersperse, isPrefixOf ) import Exception ( throwDyn, catchAllIO ) -import IO ( hPutStr, hPutChar, hPutStrLn, hFlush, stderr ) +import IO ( openFile, hClose, IOMode(..), + hPutStr, hPutChar, hPutStrLn, hFlush, stderr + ) import Directory ( doesFileExist, removeFile ) import IOExts ( IORef, readIORef, writeIORef ) import Monad ( when, unless ) import qualified System import System ( ExitCode(..) ) -import qualified Posix #include "../includes/config.h" + +#if !defined(mingw32_TARGET_OS) +import qualified Posix +#endif + #include "HsVersions.h" {-# DEPRECATED runSomething "runSomething should be private to SysTools" #-} @@ -140,43 +146,51 @@ GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager %************************************************************************ \begin{code} -initSysTools :: String -- TopDir - -- for "installed" this is the root of GHC's support files - -- for "in-place" it is the root of the build tree +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 + -> 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 -initSysTools top_dir - = do { let installed pgm = top_dir `slash` "extra-bin" `slash` pgm - inplace dir pgm = top_dir `slash` dir `slash` pgm - installed_pkgconfig = installed "package.conf" - inplace_pkgconfig = inplace cGHC_DRIVER_DIR "package.conf.inplace" +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 - -- Discover whether we're running in a build tree or in an installation, - -- by looking for the package configuration file. - ; am_installed <- doesFileExist installed_pkgconfig + ; 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!) - ; if am_installed then return () else - do config_exists <- doesFileExist inplace_pkgconfig - if config_exists then return () else - throwDyn (InstallationError - ("Can't find package.conf in " ++ - inplace_pkgconfig)) - - ; let pkgconfig_path | am_installed = installed_pkgconfig - | otherwise = inplace_pkgconfig - + ; config_exists <- doesFileExist pkgconfig_path + ; if config_exists then return () + else throwDyn (InstallationError + ("Can't find package.conf in " ++ pkgconfig_path)) + -- 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" + -- 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 + + -- 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 + + #if defined(mingw32_TARGET_OS) -- WINDOWS-SPECIFIC STUFF -- On Windows, gcc and friends are distributed with GHC, @@ -194,6 +208,11 @@ initSysTools top_dir ; let touch_path | am_installed = installed 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 @@ -205,23 +224,16 @@ initSysTools top_dir touch_path = cGHC_TOUCHY perl_path = cGHC_PERL mkdll_path = panic "Cant build DLLs on a non-Win32 system" -#endif - - -- For all systems, unlit, split, mangle are GHC utilities - -- architecture-specific stuff is done when building Config.hs - -- - -- However split and mangle are Perl scripts, and on Win32 at least - -- we don't want to rely on #!/bin/perl, so we prepend a call to Perl - ; let unlit_path | am_installed = installed cGHC_UNLIT - | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT - 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 + -- 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 + ; let split_path = split_script + mangle_path = mangle_script - split_path = perl_path ++ " " ++ split_script - mangle_path = perl_path ++ " " ++ mangle_script +#endif -- For all systems, copy and remove are provided by the host -- system; architecture-specific stuff is done when building Config.hs @@ -252,6 +264,7 @@ initSysTools top_dir ; writeIORef v_Pgm_CP cp_path ; writeIORef v_Pgm_PERL perl_path + ; return top_dir } \end{code} @@ -274,6 +287,66 @@ 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 +-- +-- 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 + String) -- TopDir + +getTopDir minusbs + = do { proto_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 (proto_top_dir `slash` "package.conf") + + ; if am_installed then + return (True, proto_top_dir) + else + return (False, remove_suffix proto_top_dir) + } + where + 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 option")) + Just dir -> return dir } + + remove_suffix dir -- "/...stuff.../ghc/compiler" --> "/...stuff..." + = ASSERT2( not (null p1) && + not (null p2) && + dosifyPath dir == dosifyPath (top_dir ++ "/ghc/compiler"), + text dir ) + top_dir + where + 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} + + %************************************************************************ %* * \subsection{Running an external program} @@ -436,7 +509,7 @@ runSomething :: String -- For -v message runSomething phase_name pgm args = traceCmd phase_name cmd_line $ - do { exit_code <- system cmd_line + do { exit_code <- System.system cmd_line ; if exit_code /= ExitSuccess then throwDyn (PhaseFailed phase_name exit_code) else return () @@ -479,14 +552,14 @@ traceCmd phase_name cmd_line action -- Convert filepath into MSDOS form. dosifyPaths :: [String] -> [String] +dosifyPath :: String -> String -- dosifyPath does two things -- a) change '/' to '\' -- b) remove initial '/cygdrive/' -#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS) +#if defined(mingw32_TARGET_OS) dosifyPaths xs = map dosifyPath xs -dosifyPath :: String -> String dosifyPath stuff = subst '/' '\\' real_stuff where @@ -501,6 +574,7 @@ dosifyPath stuff subst a b ls = map (\ x -> if x == a then b else x) ls #else dosifyPaths xs = xs +dosifyPath xs = xs #endif ----------------------------------------------------------------------------- @@ -511,14 +585,21 @@ dosifyPaths xs = xs slash :: String -> String -> String absPath, relPath :: [String] -> String -slash s1 s2 = s1 ++ ('/' : s2) - +isSlash '/' = True +isSlash '\\' = True +isSlash other = False relPath [] = "" relPath xs = foldr1 slash xs absPath xs = "" `slash` relPath xs +#if defined(mingw32_TARGET_OS) +slash s1 s2 = s1 ++ ('\\' : s2) +#else +slash s1 s2 = s1 ++ ('/' : s2) +#endif + ----------------------------------------------------------------------------- -- Convert filepath into MSDOS form. -- @@ -531,34 +612,3 @@ getProcessID :: IO Int getProcessID = Posix.getProcessID #endif \end{code} - - -%************************************************************************ -%* * -\subsection{System} -%* * -%************************************************************************ - --- This procedure executes system calls. In pre-GHC-5.00 and earlier, --- the System.system implementation didn't work, so this acts as a fix-up --- by passing the command line to 'sh'. -\begin{code} -system :: String -> IO ExitCode -system cmd - = do -#if !defined(mingw32_TARGET_OS) - -- in the case where we do want to use an MSDOS command shell, we assume - -- that files and paths have been converted to a form that's - -- understandable to the command we're invoking. - System.system cmd -#else - tmp <- newTempName "sh" - h <- openFile tmp WriteMode - hPutStrLn h cmd - hClose h - exit_code <- system ("sh - " ++ tmp) `catchAllIO` - (\exn -> removeFile tmp >> ioError exn) - removeFile tmp - return exit_code -#endif -\end{code}