Skip to content

GitLab

Commit 54f9adfa authored by simonpj's avatar simonpj
Browse files

[project @ 2001-06-14 15:42:35 by simonpj] 

Windows wibbles
parent 6e694be0
Hide whitespace changes
Inline Side-by-side
ghc/compiler/Makefile
View file @ 54f9adfa
# -----------------------------------------------------------------------------
# $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
......
ghc/compiler/main/DriverPhases.hs
View file @ 54f9adfa
-----------------------------------------------------------------------------
-- $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
-----------------------------------------------------------------------------
......
ghc/compiler/main/Main.hs
View file @ 54f9adfa
{-# 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<dir> 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).
......
ghc/compiler/main/SysTools.lhs
View file @ 54f9adfa
......@@ -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<dir> 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}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment