#ifdef __GLASGOW_HASKELL__
#define GLOBAL_VAR(name,value,ty) \
-name = global (value) :: IORef (ty); \
+name = Util.global (value) :: IORef (ty); \
{-# NOINLINE name #-}
#endif
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.155 2001/05/28 03:31:19 sof Exp $
+# $Id: Makefile,v 1.156 2001/06/14 12:50:06 simonpj Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
# -----------------------------------------------------------------------------
# Create compiler configuration
+#
+# The 'echo' commands simply spit the values of various make variables
+# into Config.hs, whence they can be compiled and used by GHC itself
CURRENT_DIR = ghc/compiler
CONFIG_HS = main/Config.hs
@echo "cHscIfaceFileVersion = \"$(HscIfaceFileVersion)\"" >> $(CONFIG_HS)
@echo "cHOSTPLATFORM = \"$(HOSTPLATFORM)\"" >> $(CONFIG_HS)
@echo "cTARGETPLATFORM = \"$(TARGETPLATFORM)\"" >> $(CONFIG_HS)
- @echo "cCURRENT_DIR = \"$(CURRENT_DIR)\"" >> $(CONFIG_HS)
- @echo "cGHC_LIB_DIR = \"$(GHC_LIB_DIR)\"" >> $(CONFIG_HS)
- @echo "cGHC_RUNTIME_DIR = \"$(GHC_RUNTIME_DIR)\"" >> $(CONFIG_HS)
- @echo "cGHC_UTILS_DIR = \"$(GHC_UTILS_DIR)\"" >> $(CONFIG_HS)
- @echo "cGHC_INCLUDE_DIR = \"$(GHC_INCLUDE_DIR)\"" >> $(CONFIG_HS)
- @echo "cGHC_DRIVER_DIR = \"$(GHC_DRIVER_DIR)\"" >> $(CONFIG_HS)
- @echo "cGCC = \"$(WhatGccIsCalled)\"" >> $(CONFIG_HS)
- @echo "cMkDLL = \"$(BLD_DLL)\"" >> $(CONFIG_HS)
@echo "cGhcWithNativeCodeGen = \"$(GhcWithNativeCodeGen)\"" >> $(CONFIG_HS)
@echo "cGhcUnregisterised = \"$(GhcUnregisterised)\"" >> $(CONFIG_HS)
@echo "cLeadingUnderscore = \"$(LeadingUnderscore)\"" >> $(CONFIG_HS)
+ @echo "cRAWCPP = \"$(GHC_RAWCPP)\"" >> $(CONFIG_HS)
+ @echo "cGCC = \"$(WhatGccIsCalled)\"" >> $(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)
@echo "cGHC_UNLIT = \"$(GHC_UNLIT)\"" >> $(CONFIG_HS)
+ @echo "cGHC_UNLIT_DIR = \"$(GHC_UNLIT_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_MANGLER = \"$(GHC_MANGLER)\"" >> $(CONFIG_HS)
+ @echo "cGHC_MANGLER_DIR = \"$(GHC_MANGLER_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_SPLIT = \"$(GHC_SPLIT)\"" >> $(CONFIG_HS)
+ @echo "cGHC_SPLIT_DIR = \"$(GHC_SPLIT_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_SYSMAN = \"$(GHC_SYSMAN)\"" >> $(CONFIG_HS)
+ @echo "cGHC_SYSMAN_DIR = \"$(GHC_SYSMAN_DIR)\"" >> $(CONFIG_HS)
+ @echo "cGHC_CP = \"$(GHC_CP)\"" >> $(CONFIG_HS)
+ @echo "cGHC_PERL = \"$(GHC_PERL)\"" >> $(CONFIG_HS)
@echo "cEnableWin32DLLs = \"$(EnableWin32DLLs)\"" >> $(CONFIG_HS)
-ifeq "$(TARGETPLATFORM) and $(MinimalUnixDeps)" "i386-unknown-mingw32 and YES"
- @echo "cCP = \"copy /y\"" >> $(CONFIG_HS)
- @echo "cRM = \"del /F /Q\"" >> $(CONFIG_HS)
- @echo "cTOUCH = \"$(GHC_TOUCHY)\"" >> $(CONFIG_HS)
-else
- @echo "cCP = \"$(CP)\"" >> $(CONFIG_HS)
- @echo "cRM = \"$(RM)\"" >> $(CONFIG_HS)
- @echo "cTOUCH = \"touch\"" >> $(CONFIG_HS)
-endif
@echo "cCONTEXT_DIFF = \"$(CONTEXT_DIFF)\"" >> $(CONFIG_HS)
@echo "cHaveLibGmp = \"$(HaveLibGmp)\"" >> $(CONFIG_HS)
@echo "cUSER_WAY_NAMES = \"$(USER_WAY_NAMES)\"" >> $(CONFIG_HS)
@echo "cUSER_WAY_OPTS = \"$(USER_WAY_OPTS)\"" >> $(CONFIG_HS)
@echo "cDEFAULT_TMPDIR = \"$(DEFAULT_TMPDIR)\"" >> $(CONFIG_HS)
-ifeq "$(TARGETPLATFORM) and $(MinimalUnixDeps)" "i386-unknown-mingw32 and YES"
- @echo "cRAWCPP = \"$(subst -mwin32,,$(RAWCPP))\"" >> $(CONFIG_HS)
-else
- @echo "cRAWCPP = \"$(RAWCPP)\"" >> $(CONFIG_HS)
-endif
@echo done.
CLEAN_FILES += $(CONFIG_HS)
main/DriverState_HC_OPTS = -fno-cse
main/DriverUtil_HC_OPTS = -fno-cse
main/Finder_HC_OPTS = -fno-cse
-main/TmpFiles_HC_OPTS = -fno-cse
+main/SysTools_HC_OPTS = -fno-cse
# ----------------------------------------------------------------------------
# C compilations
A GlobalId is
* always a constant (top-level)
* imported, or data constructor, or primop, or record selector
+ * has a Unique that is globally unique across the whole
+ GHC invocation (a single invocation may compile multiple modules)
A LocalId is
* bound within an expression (lambda, case, local let(rec))
import Outputable
import ErrUtils ( showPass )
import CmdLineOpts ( DynFlags(..) )
-import Panic ( panic, GhcException(..) )
+import Panic ( panic )
-import Exception
import List
import Monad
import IO
linkObjs (objs ++ bcos) pls
-- get the objects first
-ppLinkableSCC :: SCC Linkable -> SDoc
-ppLinkableSCC = ppr . flattenSCC
-
filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
filterModuleLinkables p [] = []
filterModuleLinkables p (li:lis)
import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp, flattenSCC )
import ErrUtils ( showPass )
+import SysTools ( cleanTempFilesExcept )
import Util
-import TmpFiles
import Outputable
import Panic
import CmdLineOpts ( DynFlags(..) )
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.73 2001/06/07 16:00:18 sewardj Exp $
+-- $Id: InteractiveUI.hs,v 1.74 2001/06/14 12:50:06 simonpj Exp $
--
-- GHC Interactive User Interface
--
import Util
import Name ( Name )
import Outputable
-import CmdLineOpts ( DynFlag(..), dopt_unset )
+import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
import Panic ( GhcException(..) )
import Config
= return Nothing
| otherwise
= do st <- getGHCiState
- dflags <- io (getDynFlags)
+ dflags <- io getDynFlags
let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
(new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
setGHCiState st{cmstate = new_cmstate}
-- compile the expression
st <- getGHCiState
- dflags <- io (getDynFlags)
+ dflags <- io getDynFlags
(new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
setGHCiState st{cmstate = new_cmstate}
case maybe_hv of
loadModule' path = do
state <- getGHCiState
- dflags <- io (getDynFlags)
+ dflags <- io getDynFlags
cmstate1 <- io (cmUnload (cmstate state) dflags)
setGHCiState state{ cmstate = cmstate1, target = Nothing }
io (revertCAFs) -- always revert CAFs on load.
typeOfExpr :: String -> GHCi ()
typeOfExpr str
= do st <- getGHCiState
- dflags <- io (getDynFlags)
+ dflags <- io getDynFlags
(new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
setGHCiState st{cmstate = new_cmstate}
case maybe_tystr of
-- then, dynamic flags
io $ do
- dyn_flags <- readIORef v_InitDynFlags
- writeIORef v_DynFlags dyn_flags
+ restoreDynFlags
leftovers <- processArgs dynamic_flags leftovers []
- dyn_flags <- readIORef v_DynFlags
- writeIORef v_InitDynFlags dyn_flags
+ saveDynFlags
if (not (null leftovers))
then throwDyn (CmdLineError ("unrecognised flags: " ++
newPackages new_pkgs = do
state <- getGHCiState
- dflags <- io (getDynFlags)
+ dflags <- io getDynFlags
cmstate1 <- io (cmUnload (cmstate state) dflags)
setGHCiState state{ cmstate = cmstate1, target = Nothing }
HscLang(..),
DynFlag(..), -- needed non-abstractly by DriverFlags
DynFlags(..),
- defaultDynFlags,
v_Static_hsc_opts,
switchIsOn,
isStaticHscFlag,
- opt_PprStyle_NoPrags,
- opt_PprStyle_RawTypes,
- opt_PprUserLength,
- opt_PprStyle_Debug,
-
- dopt,
- dopt_set,
- dopt_unset,
-
- -- other dynamic flags
- dopt_CoreToDo,
- dopt_StgToDo,
- dopt_HscLang,
- dopt_OutName,
+ -- Manipulating DynFlags
+ defaultDynFlags, -- DynFlags
+ dopt, -- DynFlag -> DynFlags -> Bool
+ dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags
+ dopt_CoreToDo, -- DynFlags -> [CoreToDo]
+ dopt_StgToDo, -- DynFlags -> [StgToDo]
+ dopt_HscLang, -- DynFlags -> HscLang
+ dopt_OutName, -- DynFlags -> String
+
+ -- Manipulating the DynFlags state
+ getDynFlags, -- IO DynFlags
+ setDynFlags, -- DynFlags -> IO ()
+ updDynFlags, -- (DynFlags -> DynFlags) -> IO ()
+ dynFlag, -- (DynFlags -> a) -> IO a
+ setDynFlag, unSetDynFlag, -- DynFlag -> IO ()
+ saveDynFlags, -- IO ()
+ restoreDynFlags, -- IO DynFlags
-- sets of warning opts
standardWarnings,
minusWOpts,
minusWallOpts,
+ -- Output style options
+ opt_PprStyle_NoPrags,
+ opt_PprStyle_RawTypes,
+ opt_PprUserLength,
+ opt_PprStyle_Debug,
+
-- profiling opts
opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs,
import Array ( array, (//) )
import GlaExts
-import IOExts ( IORef, readIORef )
+import IOExts ( IORef, readIORef, writeIORef )
import Constants -- Default values for some flags
import Util
import FastTypes
flags :: [DynFlag]
}
+data HscLang
+ = HscC
+ | HscAsm
+ | HscJava
+ | HscILX
+ | HscInterpreted
+ deriving (Eq, Show)
+
defaultDynFlags = DynFlags {
coreToDo = [], stgToDo = [],
hscLang = HscC,
dopt_OutName :: DynFlags -> String
dopt_OutName = hscOutName
+dopt_HscLang :: DynFlags -> HscLang
+dopt_HscLang = hscLang
+
dopt_set :: DynFlags -> DynFlag -> DynFlags
dopt_set dfs f = dfs{ flags = f : flags dfs }
dopt_unset :: DynFlags -> DynFlag -> DynFlags
dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }
+\end{code}
-data HscLang
- = HscC
- | HscAsm
- | HscJava
- | HscILX
- | HscInterpreted
- deriving (Eq, Show)
+-----------------------------------------------------------------------------
+-- Mess about with the mutable variables holding the dynamic arguments
-dopt_HscLang :: DynFlags -> HscLang
-dopt_HscLang = hscLang
+-- v_InitDynFlags
+-- is the "baseline" dynamic flags, initialised from
+-- the defaults and command line options, and updated by the
+-- ':s' command in GHCi.
+--
+-- v_DynFlags
+-- is the dynamic flags for the current compilation. It is reset
+-- to the value of v_InitDynFlags before each compilation, then
+-- updated by reading any OPTIONS pragma in the current module.
+
+\begin{code}
+GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
+GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
+
+setDynFlags :: DynFlags -> IO ()
+setDynFlags dfs = writeIORef v_DynFlags dfs
+
+saveDynFlags :: IO ()
+saveDynFlags = do dfs <- readIORef v_DynFlags
+ writeIORef v_InitDynFlags dfs
+
+restoreDynFlags :: IO DynFlags
+restoreDynFlags = do dfs <- readIORef v_InitDynFlags
+ writeIORef v_DynFlags dfs
+ return dfs
+
+getDynFlags :: IO DynFlags
+getDynFlags = readIORef v_DynFlags
+
+updDynFlags :: (DynFlags -> DynFlags) -> IO ()
+updDynFlags f = do dfs <- readIORef v_DynFlags
+ writeIORef v_DynFlags (f dfs)
+
+dynFlag :: (DynFlags -> a) -> IO a
+dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags)
+
+setDynFlag, unSetDynFlag :: DynFlag -> IO ()
+setDynFlag f = updDynFlags (\dfs -> dopt_set dfs f)
+unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f)
\end{code}
+
%************************************************************************
%* *
\subsection{Warnings}
{-# OPTIONS -#include "hschooks.h" #-}
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.57 2001/06/13 15:50:25 rrt Exp $
+-- $Id: DriverFlags.hs,v 1.58 2001/06/14 12:50:06 simonpj Exp $
--
-- Driver flags
--
module DriverFlags (
processArgs, OptKind(..), static_flags, dynamic_flags,
- v_InitDynFlags, v_DynFlags, getDynFlags, dynFlag,
+ getDynFlags, dynFlag,
getOpts, getVerbFlag, addCmdlineHCInclude,
buildStaticHscOpts,
- runSomething,
machdepCCOpts
) where
import DriverState
import DriverUtil
-import TmpFiles ( v_TmpDir )
+import SysTools ( setTmpDir, setPgm, setDryRun, showGhcUsage )
import CmdLineOpts
import Config
import Util
import Exception
import IOExts
+import System ( exitWith, ExitCode(..) )
import IO
import Maybe
import Monad
-import System
import Char
-----------------------------------------------------------------------------
| AnySuffixPred (String -> Bool) (String -> IO ())
processArgs :: [(String,OptKind)] -> [String] -> [String]
- -> IO [String] -- returns spare args
+ -> IO [String] -- returns spare args
processArgs _spec [] spare = return (reverse spare)
+
processArgs spec args@(('-':arg):args') spare = do
case findArg spec arg of
- Just (rest,action) ->
- do args' <- processOneArg action rest args
- processArgs spec args' spare
- Nothing ->
- processArgs spec args' (('-':arg):spare)
+ Just (rest,action) -> do args' <- processOneArg action rest args
+ processArgs spec args' spare
+ Nothing -> processArgs spec args' (('-':arg):spare)
+
processArgs spec (arg:args) spare =
processArgs spec args (arg:spare)
findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind)
findArg spec arg
= case [ (remove_spaces rest, k)
- | (pat,k) <- spec, Just rest <- [my_prefix_match pat arg],
+ | (pat,k) <- spec,
+ Just rest <- [my_prefix_match pat arg],
arg_ok k rest arg ]
of
[] -> Nothing
static_flags =
[ ------- help -------------------------------------------------------
- ( "?" , NoArg long_usage)
- , ( "-help" , NoArg long_usage)
+ ( "?" , NoArg showGhcUsage)
+ , ( "-help" , NoArg showGhcUsage)
------- version ----------------------------------------------------
exitWith ExitSuccess))
------- verbosity ----------------------------------------------------
- , ( "n" , NoArg (writeIORef v_Dry_run True) )
+ , ( "n" , NoArg setDryRun )
------- recompilation checker --------------------------------------
, ( "recomp" , NoArg (writeIORef v_Recomp True) )
, ( "hisuf" , HasArg (writeIORef v_Hi_suf) )
, ( "hidir" , HasArg (writeIORef v_Hi_dir . Just) )
, ( "buildtag" , HasArg (writeIORef v_Build_tag) )
- , ( "tmpdir" , HasArg (writeIORef v_TmpDir . (++ "/")) )
+ , ( "tmpdir" , HasArg setTmpDir)
, ( "ohi" , HasArg (writeIORef v_Output_hi . Just) )
-- -odump?
, ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns
------- Specific phases --------------------------------------------
- , ( "pgmL" , HasArg (writeIORef v_Pgm_L) )
- , ( "pgmP" , HasArg (writeIORef v_Pgm_P) )
- , ( "pgmc" , HasArg (writeIORef v_Pgm_c) )
- , ( "pgmm" , HasArg (writeIORef v_Pgm_m) )
- , ( "pgms" , HasArg (writeIORef v_Pgm_s) )
- , ( "pgma" , HasArg (writeIORef v_Pgm_a) )
- , ( "pgml" , HasArg (writeIORef v_Pgm_l) )
+ , ( "pgm" , HasArg setPgm )
, ( "optdep" , HasArg (add v_Opt_dep) )
, ( "optl" , HasArg (add v_Opt_l) )
, ( "f", AnySuffixPred (isStaticHscFlag) (add v_Opt_C) )
]
------------------------------------------------------------------------------
--- parse the dynamic arguments
-
--- v_InitDynFlags
--- is the "baseline" dynamic flags, initialised from
--- the defaults and command line options, and updated by the
--- ':s' command in GHCi.
---
--- v_DynFlags
--- is the dynamic flags for the current compilation. It is reset
--- to the value of v_InitDynFlags before each compilation, then
--- updated by reading any OPTIONS pragma in the current module.
-
-GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
-GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
-
-updDynFlags f = do
- dfs <- readIORef v_DynFlags
- writeIORef v_DynFlags (f dfs)
-
-getDynFlags :: IO DynFlags
-getDynFlags = readIORef v_DynFlags
-
-dynFlag :: (DynFlags -> a) -> IO a
-dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags)
-
-setDynFlag f = updDynFlags (\dfs -> dopt_set dfs f)
-unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f)
-
-addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s})
-addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s})
-addOpt_c a = updDynFlags (\s -> s{opt_c = a : opt_c s})
-addOpt_a a = updDynFlags (\s -> s{opt_a = a : opt_a s})
-addOpt_m a = updDynFlags (\s -> s{opt_m = a : opt_m s})
-
-addCmdlineHCInclude a =
- updDynFlags (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s})
-
- -- we add to the options from the front, so we need to reverse the list
-getOpts :: (DynFlags -> [a]) -> IO [a]
-getOpts opts = dynFlag opts >>= return . reverse
-
--- we can only change HscC to HscAsm and vice-versa with dynamic flags
--- (-fvia-C and -fasm).
--- NB: we can also set the new lang to ILX, via -filx. I hope this is right
-setLang l = do
- dfs <- readIORef v_DynFlags
- case hscLang dfs of
- HscC -> writeIORef v_DynFlags dfs{ hscLang = l }
- HscAsm -> writeIORef v_DynFlags dfs{ hscLang = l }
- HscILX -> writeIORef v_DynFlags dfs{ hscLang = l }
- _ -> return ()
-
-setVerbosityAtLeast n =
- updDynFlags (\dfs -> if verbosity dfs < n
- then dfs{ verbosity = n }
- else dfs)
-
-setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 })
-setVerbosity n
- | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n })
- | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v<n>)")
-
-getVerbFlag = do
- verb <- dynFlag verbosity
- if verb >= 3 then return "-v" else return ""
-
dynamic_flags = [
( "cpp", NoArg (updDynFlags (\s -> s{ cppFlag = True })) )
n = read m :: Double
pred c = isDigit c || c == '.'
-floatOpt :: IORef Double -> String -> IO ()
-floatOpt ref str = writeIORef ref (read str :: Double)
-----------------------------------------------------------------------------
-- RTS Hooks
return ( static : filtered_opts )
-----------------------------------------------------------------------------
--- Running an external program
-
--- sigh, here because both DriverMkDepend & DriverPipeline need it.
-
-runSomething phase_name cmd
- = do
- verb <- dynFlag verbosity
- when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
- when (verb >= 3) $ hPutStrLn stderr cmd
- hFlush stderr
-
- -- test for -n flag
- n <- readIORef v_Dry_run
- unless n $ do
-
- -- and run it!
- exit_code <- system cmd
-
- if exit_code /= ExitSuccess
- then throwDyn (PhaseFailed phase_name exit_code)
- else do when (verb >= 3) (hPutStr stderr "\n")
- return ()
-
------------------------------------------------------------------------------
-- Via-C compilation stuff
-- flags returned are: ( all C compilations
| otherwise
= return ( [], [] )
+
+
+
+addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s})
+addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s})
+addOpt_c a = updDynFlags (\s -> s{opt_c = a : opt_c s})
+addOpt_a a = updDynFlags (\s -> s{opt_a = a : opt_a s})
+addOpt_m a = updDynFlags (\s -> s{opt_m = a : opt_m s})
+
+addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s})
+
+getOpts :: (DynFlags -> [a]) -> IO [a]
+ -- We add to the options from the front, so we need to reverse the list
+getOpts opts = dynFlag opts >>= return . reverse
+
+-- we can only change HscC to HscAsm and vice-versa with dynamic flags
+-- (-fvia-C and -fasm).
+-- NB: we can also set the new lang to ILX, via -filx. I hope this is right
+setLang l = updDynFlags (\ dfs -> case hscLang dfs of
+ HscC -> dfs{ hscLang = l }
+ HscAsm -> dfs{ hscLang = l }
+ HscILX -> dfs{ hscLang = l }
+ _ -> dfs)
+
+setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 })
+setVerbosity n
+ | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n })
+ | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v<n>)")
+
+getVerbFlag = do
+ verb <- dynFlag verbosity
+ if verb >= 3 then return "-v" else return ""
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.11 2001/05/28 03:31:19 sof Exp $
+-- $Id: DriverMkDepend.hs,v 1.12 2001/06/14 12:50:06 simonpj Exp $
--
-- GHC Driver
--
import DriverState
import DriverUtil
import DriverFlags
-import TmpFiles
+import SysTools ( newTempName )
+import qualified SysTools
import Module
import Config
import Util
hClose tmp_hdl -- make sure it's flushed
- -- create a backup of the original makefile
- when (isJust makefile_hdl) $
- runSomething ("Backing up " ++ makefile)
- (unwords [ cCP, dosifyPath makefile, dosifyPath $ makefile++".bak" ])
+ -- Create a backup of the original makefile
+ when (isJust makefile_hdl)
+ (SysTools.copy ("Backing up " ++ makefile) makefile (makefile++".bak"))
- -- copy the new makefile in place
- runSomething "Installing new makefile"
- (unwords [ cCP, dosifyPath tmp_file, dosifyPath makefile ])
+ -- Copy the new makefile in place
+ SysTools.copy "Installing new makefile" tmp_file makefile
findDependency :: Bool -> FilePath -> ModuleName -> IO (Maybe (String, Bool))
-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.77 2001/06/14 11:46:55 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.78 2001/06/14 12:50:06 simonpj Exp $
--
-- GHC Driver
--
import DriverMkDepend
import DriverPhases
import DriverFlags
+import SysTools ( newTempName, addFilesToClean, getSysMan )
+import qualified SysTools
import HscMain
-import TmpFiles
import Finder
import HscTypes
import Outputable
-- Unlit phase
run_phase Unlit _basename _suff input_fn output_fn
- = do unlit <- readIORef v_Pgm_L
- unlit_flags <- getOpts opt_L
- runSomething "Literate pre-processor"
- (unlit ++ unwords unlit_flags ++
- " -h " ++ input_fn ++
- ' ':input_fn ++
- ' ':output_fn)
+ = do unlit_flags <- getOpts opt_L
+ SysTools.runUnlit (unlit_flags ++ ["-h", input_fn, input_fn, output_fn])
return True
-------------------------------------------------------------------------------
do_cpp <- dynFlag cppFlag
if do_cpp
then do
- cpp <- readIORef v_Pgm_P >>= prependToolDir
- hscpp_opts <- getOpts opt_P
+ hscpp_opts <- getOpts opt_P
hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
cmdline_include_paths <- readIORef v_Include_paths
verb <- getVerbFlag
(md_c_flags, _) <- machdepCCOpts
- runSomething "C pre-processor"
- (unwords
- ([cpp, verb]
- ++ include_paths
- ++ hs_src_cpp_opts
- ++ hscpp_opts
- ++ md_c_flags
- ++ [ "-x", "c", input_fn, "-o", output_fn ]
- ))
+ SysTools.runCpp ([verb]
+ ++ include_paths
+ ++ hs_src_cpp_opts
+ ++ hscpp_opts
+ ++ md_c_flags
+ ++ [ "-x", "c", input_fn, "-o", output_fn ])
+
-- ToDo: switch away from using 'echo' alltogether (but need
-- a faster alternative than what's done below).
#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
(\_ -> throwDyn (PhaseFailed "Ineffective C pre-processor" (ExitFailure 1)))
#else
else do
- runSomething "Ineffective C pre-processor"
+ SysTools.runSomething "Ineffective C pre-processor"
("echo '{-# LINE 1 \"" ++ input_fn ++ "\" #-}' > "
++ output_fn ++ " && cat " ++ input_fn
- ++ " >> " ++ output_fn)
+ ++ " >> " ++ output_fn) []
#endif
return True
run_phase MkDependHS basename suff input_fn _output_fn = do
src <- readFile input_fn
- let (import_sources, import_normals, module_name) = getImports src
+ let (import_sources, import_normals, _) = getImports src
let orig_fn = basename ++ '.':suff
deps_sources <- mapM (findDependency True orig_fn) import_sources
else return False
-- get the DynFlags
- dyn_flags <- readIORef v_DynFlags
+ dyn_flags <- getDynFlags
let dyn_flags' = dyn_flags { hscOutName = output_fn,
hscStubCOutName = basename ++ "_stub.c",
HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1));
- HscNoRecomp pcs details iface ->
- do {
-#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
- touch <- readIORef v_Pgm_T;
- runSomething "Touching object file" (unwords [dosifyPath touch, dosifyPath o_file]);
-#else
- runSomething "Touching object file" (unwords [cTOUCH, o_file]);
-#endif
- return False;
- };
+ HscNoRecomp pcs details iface -> do { SysTools.touch "Touching object file" o_file
+ ; return False } ;
HscRecomp pcs details iface stub_h_exists stub_c_exists
_maybe_interpreted_code -> do
run_phase cc_phase basename suff input_fn output_fn
| cc_phase == Cc || cc_phase == HCc
- = do cc <- readIORef v_Pgm_c >>= prependToolDir >>= appendInstallDir
- cc_opts <- (getOpts opt_c)
+ = do cc_opts <- getOpts opt_c
cmdline_include_dirs <- readIORef v_Include_paths
let hcc = cc_phase == HCc
| otherwise = [ ]
excessPrecision <- readIORef v_Excess_precision
- runSomething "C Compiler"
- (unwords ([ cc, "-x", "c", input_fn, "-o", output_fn ]
- ++ md_c_flags
- ++ (if cc_phase == HCc && mangle
- then md_regd_c_flags
- else [])
- ++ [ verb, "-S", "-Wimplicit", opt_flag ]
- ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
- ++ cc_opts
- ++ split_opt
- ++ (if excessPrecision then [] else [ "-ffloat-store" ])
- ++ include_paths
- ++ pkg_extra_cc_opts
- ))
+ SysTools.runCc ([ "-x", "c", input_fn, "-o", output_fn ]
+ ++ md_c_flags
+ ++ (if cc_phase == HCc && mangle
+ then md_regd_c_flags
+ else [])
+ ++ [ verb, "-S", "-Wimplicit", opt_flag ]
+ ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
+ ++ cc_opts
+ ++ split_opt
+ ++ (if excessPrecision then [] else [ "-ffloat-store" ])
+ ++ include_paths
+ ++ pkg_extra_cc_opts
+ )
return True
-- ToDo: postprocess the output from gcc
-- Mangle phase
run_phase Mangle _basename _suff input_fn output_fn
- = do mangler <- readIORef v_Pgm_m
- mangler_opts <- getOpts opt_m
- machdep_opts <-
- if (prefixMatch "i386" cTARGETPLATFORM)
- then do n_regs <- dynFlag stolen_x86_regs
- return [ show n_regs ]
- else return []
-#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
- perl_path <- prependToolDir ("perl")
- let real_mangler = unwords [perl_path, mangler]
-#else
- let real_mangler = mangler
-#endif
- runSomething "Assembly Mangler"
- (unwords (real_mangler : mangler_opts
- ++ [ input_fn, output_fn ]
- ++ machdep_opts
- ))
+ = do mangler_opts <- getOpts opt_m
+ machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
+ then do n_regs <- dynFlag stolen_x86_regs
+ return [ show n_regs ]
+ else return []
+
+ SysTools.runMangle (mangler_opts
+ ++ [ input_fn, output_fn ]
+ ++ machdep_opts)
return True
-----------------------------------------------------------------------------
-- Splitting phase
run_phase SplitMangle _basename _suff input_fn _output_fn
- = do splitter <- readIORef v_Pgm_s
- -- this is the prefix used for the split .s files
- tmp_pfx <- readIORef v_TmpDir
- x <- myGetProcessID
- let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
- writeIORef v_Split_prefix split_s_prefix
- addFilesToClean [split_s_prefix ++ "__*"] -- d:-)
+ = do -- tmp_pfx is the prefix used for the split .s files
+ -- We also use it as the file to contain the no. of split .s files (sigh)
+ split_s_prefix <- SysTools.newTempName "split"
+ let n_files_fn = split_s_prefix
- -- allocate a tmp file to put the no. of split .s files in (sigh)
- n_files <- newTempName "n_files"
+ SysTools.runSplit [input_fn, split_s_prefix, n_files_fn]
+
+ -- Save the number of split files for future references
+ s <- readFile n_files_fn
+ let n_files = read s :: Int
+ writeIORef v_Split_info (split_s_prefix, n_files)
+
+ -- Remember to delete all these files
+ addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
+ | n <- [1..n_files]]
-#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
- perl_path <- prependToolDir ("perl")
- let real_splitter = unwords [perl_path, splitter]
-#else
- let real_splitter = splitter
-#endif
- runSomething "Split Assembly File"
- (unwords [ real_splitter
- , input_fn
- , split_s_prefix
- , n_files ]
- )
-
- -- save the number of split files for future references
- s <- readFile n_files
- let n = read s :: Int
- writeIORef v_N_split_files n
return True
-----------------------------------------------------------------------------
-- As phase
run_phase As _basename _suff input_fn output_fn
- = do as <- readIORef v_Pgm_a >>= prependToolDir >>= appendInstallDir
- as_opts <- getOpts opt_a
-
+ = do as_opts <- getOpts opt_a
cmdline_include_paths <- readIORef v_Include_paths
- let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
- runSomething "Assembler"
- (unwords (as : as_opts
- ++ cmdline_include_flags
- ++ [ "-c", input_fn, "-o", output_fn ]
- ))
+
+ SysTools.runAs (as_opts
+ ++ [ "-I" ++ p | p <- cmdline_include_paths ]
+ ++ [ "-c", input_fn, "-o", output_fn ])
return True
run_phase SplitAs basename _suff _input_fn _output_fn
- = do as <- readIORef v_Pgm_a
- as_opts <- getOpts opt_a
+ = do as_opts <- getOpts opt_a
- split_s_prefix <- readIORef v_Split_prefix
- n <- readIORef v_N_split_files
+ (split_s_prefix, n) <- readIORef v_Split_info
odir <- readIORef v_Output_dir
let real_odir = case odir of
Nothing -> basename
Just d -> d
- let assemble_file n = do
- let input_s = split_s_prefix ++ "__" ++ show n ++ ".s"
+ let assemble_file n
+ = do let input_s = split_s_prefix ++ "__" ++ show n ++ ".s"
let output_o = newdir real_odir
(basename ++ "__" ++ show n ++ ".o")
real_o <- osuf_ify output_o
- runSomething "Assembler"
- (unwords (as : as_opts
- ++ [ "-c", "-o", real_o, input_s ]
- ))
+ SysTools.runAs (as_opts ++ ["-c", "-o", real_o, input_s])
mapM_ assemble_file [1..n]
return True
run_phase_MoveBinary input_fn
= do
- top_dir <- readIORef v_TopDir
+ sysMan <- getSysMan
pvm_root <- getEnv "PVM_ROOT"
pvm_arch <- getEnv "PVM_ARCH"
let
pvm_executable_base = "=" ++ input_fn
pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
- sysMan = top_dir ++ "/ghc/rts/parallel/SysMan";
-- nuke old binary; maybe use configur'ed names for cp and rm?
system ("rm -f " ++ pvm_executable)
-- move the newly created binary into PVM land
doLink :: [String] -> IO ()
doLink o_files = do
- ln <- readIORef v_Pgm_l >>= prependToolDir >>= appendInstallDir
- verb <- getVerbFlag
- static <- readIORef v_Static
- let imp = if static then "" else "_imp"
+ verb <- getVerbFlag
+ static <- readIORef v_Static
no_hs_main <- readIORef v_NoHsMain
o_file <- readIORef v_Output_file
let lib_path_opts = map ("-L"++) lib_paths
pkg_libs <- getPackageLibraries
- let pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
+ let imp = if static then "" else "_imp"
+ pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
libs <- readIORef v_Cmdline_libraries
let lib_opts = map ("-l"++) (reverse libs)
rts_pkg <- getPackageDetails ["rts"]
std_pkg <- getPackageDetails ["std"]
-#ifdef mingw32_TARGET_OS
let extra_os = if static || no_hs_main
then []
else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
-#endif
+
(md_c_flags, _) <- machdepCCOpts
- runSomething "Linker"
- (unwords
- ([ ln, verb, "-o", output_fn ]
- ++ md_c_flags
- ++ o_files
-#ifdef mingw32_TARGET_OS
- ++ extra_os
-#endif
- ++ extra_ld_inputs
- ++ lib_path_opts
- ++ lib_opts
- ++ pkg_lib_path_opts
- ++ pkg_lib_opts
- ++ pkg_extra_ld_opts
- ++ extra_ld_opts
-#ifdef mingw32_TARGET_OS
- ++ if static then [ "-u _PrelMain_mainIO_closure" , "-u ___init_PrelMain"] else []
-#else
- ++ [ "-u PrelMain_mainIO_closure" , "-u __init_PrelMain"]
-#endif
- )
- )
+ SysTools.runLink ( [verb, "-o", output_fn]
+ ++ md_c_flags
+ ++ o_files
+ ++ extra_os
+ ++ extra_ld_inputs
+ ++ lib_path_opts
+ ++ lib_opts
+ ++ pkg_lib_path_opts
+ ++ pkg_lib_opts
+ ++ pkg_extra_ld_opts
+ ++ extra_ld_opts
+ ++ if static then [ "-u _PrelMain_mainIO_closure" , "-u ___init_PrelMain"] else [])
+
-- parallel only: move binary to another dir -- HWL
ways_ <- readIORef v_Ways
- when (WayPar `elem` ways_) (do
- success <- run_phase_MoveBinary output_fn
- if success then return ()
- else throwDyn (InstallationError ("cannot move binary to PVM dir")))
+ when (WayPar `elem` ways_)
+ (do success <- run_phase_MoveBinary output_fn
+ if success then return ()
+ else throwDyn (InstallationError ("cannot move binary to PVM dir")))
-----------------------------------------------------------------------------
--- Making a DLL
+-- Making a DLL (only for Win32)
--- only for Win32, but bits that are #ifdefed in doLn are still #ifdefed here
--- in a vain attempt to aid future portability
doMkDLL :: [String] -> IO ()
doMkDLL o_files = do
- ln <- readIORef v_Pgm_dll >>= prependToolDir >>= appendInstallDir
- verb <- getVerbFlag
- static <- readIORef v_Static
- let imp = if static then "" else "_imp"
+ verb <- getVerbFlag
+ static <- readIORef v_Static
no_hs_main <- readIORef v_NoHsMain
o_file <- readIORef v_Output_file
let lib_path_opts = map ("-L"++) lib_paths
pkg_libs <- getPackageLibraries
- let pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
+ let imp = if static then "" else "_imp"
+ pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
libs <- readIORef v_Cmdline_libraries
let lib_opts = map ("-l"++) (reverse libs)
rts_pkg <- getPackageDetails ["rts"]
std_pkg <- getPackageDetails ["std"]
-#ifdef mingw32_TARGET_OS
+
let extra_os = if static || no_hs_main
then []
else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
-#endif
+
(md_c_flags, _) <- machdepCCOpts
- runSomething "DLL creator"
- (unwords
- ([ ln, verb, "-o", output_fn ]
+ SysTools.runMkDLL
+ ([ verb, "-o", output_fn ]
++ md_c_flags
++ o_files
-#ifdef mingw32_TARGET_OS
++ extra_os
++ [ "--target=i386-mingw32" ]
-#endif
++ extra_ld_inputs
++ lib_path_opts
++ lib_opts
Just _ -> [ "" ])
++ extra_ld_opts
)
- )
-----------------------------------------------------------------------------
-- Just preprocess a file, put the result in a temp. file (used by the
preprocess :: FilePath -> IO FilePath
preprocess filename =
ASSERT(haskellish_src_file filename)
- do init_dyn_flags <- readIORef v_InitDynFlags
- writeIORef v_DynFlags init_dyn_flags
+ do restoreDynFlags -- Restore to state of last save
pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
- defaultHscLang filename
+ defaultHscLang filename
runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
-----------------------------------------------------------------------------
compile ghci_mode summary source_unchanged have_object
old_iface hst hit pcs = do
- init_dyn_flags <- readIORef v_InitDynFlags
- writeIORef v_DynFlags init_dyn_flags
+ dyn_flags <- restoreDynFlags -- Restore to the state of the last save
+
- showPass init_dyn_flags
+ showPass dyn_flags
(showSDoc (text "Compiling" <+> ppr (name_of_summary summary)))
- let verb = verbosity init_dyn_flags
+ let verb = verbosity dyn_flags
let location = ms_location summary
let input_fn = unJust "compile:hs" (ml_hs_file location)
let input_fnpp = unJust "compile:hspp" (ml_hspp_file location)
opts <- getOptionsFromSource input_fnpp
processArgs dynamic_flags opts []
- dyn_flags <- readIORef v_DynFlags
+ dyn_flags <- getDynFlags
- let hsc_lang = hscLang dyn_flags
+ let hsc_lang = hscLang dyn_flags
(basename, _) = splitFilename input_fn
output_fn <- case hsc_lang of
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.43 2001/06/13 10:23:23 simonmar Exp $
+-- $Id: DriverState.hs,v 1.44 2001/06/14 12:50:06 simonpj Exp $
--
-- Settings for the driver
--
import Config
import Exception
import IOExts
-#ifdef mingw32_TARGET_OS
-import TmpFiles ( newTempName )
-import Directory ( removeFile )
-#endif
import Panic
import List
-----------------------------------------------------------------------------
-- Global compilation flags
--- location of compiler-related files
-GLOBAL_VAR(v_TopDir, error "no TOPDIR", String)
-
-- Cpp-related flags
v_Hs_source_cpp_opts = global
[ "-D__HASKELL1__="++cHaskell1Version
-- Misc
GLOBAL_VAR(v_Scale_sizes_by, 1.0, Double)
-GLOBAL_VAR(v_Dry_run, False, Bool)
GLOBAL_VAR(v_Static, True, Bool)
GLOBAL_VAR(v_NoHsMain, False, Bool)
GLOBAL_VAR(v_Recomp, True, Bool)
-- Splitting object files (for libraries)
GLOBAL_VAR(v_Split_object_files, False, Bool)
-GLOBAL_VAR(v_Split_prefix, "", String)
-GLOBAL_VAR(v_N_split_files, 0, Int)
+GLOBAL_VAR(v_Split_info, ("",0), (String,Int))
+ -- The split prefix and number of files
+
can_split :: Bool
can_split = prefixMatch "i386" cTARGETPLATFORM
-----------------------------------------------------------------------------
-- Packages
-GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
-
-- package list is maintained in dependency order
GLOBAL_VAR(v_Packages, ("std":"rts":"gmp":[]), [String])
-----------------------------------------------------------------------------
-- Programs for particular phases
-GLOBAL_VAR(v_Pgm_L, error "pgm_L", String)
-GLOBAL_VAR(v_Pgm_P, cRAWCPP, String)
-GLOBAL_VAR(v_Pgm_c, cGCC, String)
-GLOBAL_VAR(v_Pgm_m, error "pgm_m", String)
-GLOBAL_VAR(v_Pgm_s, error "pgm_s", String)
-GLOBAL_VAR(v_Pgm_a, cGCC, String)
-GLOBAL_VAR(v_Pgm_l, cGCC, String)
-GLOBAL_VAR(v_Pgm_dll, cMkDLL, String)
-
-#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
-GLOBAL_VAR(v_Pgm_T, cTOUCH, String)
-#endif
-
GLOBAL_VAR(v_Opt_dep, [], [String])
GLOBAL_VAR(v_Anti_opt_C, [], [String])
GLOBAL_VAR(v_Opt_C, [], [String])
-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.23 2001/06/02 09:45:51 qrczak Exp $
+-- $Id: DriverUtil.hs,v 1.24 2001/06/14 12:50:06 simonpj Exp $
--
-- Utils for the driver
--
import Directory ( getDirectoryContents )
import IO
-import System
import List
import Char
import Monad
-#ifndef mingw32_TARGET_OS
-import Posix
-#endif
-----------------------------------------------------------------------------
-- Errors
-GLOBAL_VAR(v_Path_usage, "", String)
-
-long_usage = 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
-
-----------------------------------------------------------------------------
-- Reading OPTIONS pragmas
Just b -> ((a,b):bs,cs)
my_prefix_match :: String -> String -> Maybe String
-my_prefix_match [] rest = Just rest
-my_prefix_match (_:_) [] = Nothing
+my_prefix_match [] rest = Just rest
+my_prefix_match (_:_) [] = Nothing
my_prefix_match (p:pat) (r:rest)
| p == r = my_prefix_match pat rest
| otherwise = Nothing
xs <- readIORef var
unless (x `elem` xs) $ writeIORef var (x:xs)
-splitFilename :: String -> (String,String)
+------------------------------------------------------
+-- Filename manipulation
+------------------------------------------------------
+
+type Suffix = String
+
+splitFilename :: String -> (String,Suffix)
splitFilename f = split_longest_prefix f '.'
-getFileSuffix :: String -> String
+getFileSuffix :: String -> Suffix
getFileSuffix f = drop_longest_prefix f '.'
-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
-splitFilename3 :: String -> (String,String,String)
+splitFilename3 :: String -> (String,String,Suffix)
splitFilename3 str
= let (dir, rest) = split_longest_prefix str '/'
(name, ext) = splitFilename rest
| otherwise = dir
in (real_dir, name, ext)
-remove_suffix :: Char -> String -> String
+remove_suffix :: Char -> String -> Suffix
remove_suffix c s
| null pre = reverse suf
| otherwise = reverse pre
(_:pre) -> (reverse pre, reverse suf)
where (suf,pre) = break (==c) (reverse s)
-newsuf :: String -> String -> String
+newsuf :: String -> Suffix -> String
newsuf suf s = remove_suffix '.' s ++ suf
-- getdir strips the filename off the input string, returning the directory.
remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
-ghcToolDir :: String
-prependToolDir :: String -> IO String
-#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
-ghcToolDir = unsafePerformIO $ do
- bs <- getEnv "GHC_TOOLDIR" `IO.catch` (\ _ -> return "")
- case bs of
- "" -> return bs
- ls ->
- let
- term = last ls
- bs'
- | term `elem` ['/', '\\'] = bs
- | otherwise = bs ++ ['/']
- in
- return bs'
-
-prependToolDir x = return (dosifyPath (ghcToolDir ++ x))
-#else
-ghcToolDir = ""
-prependToolDir x = return x
-#endif
-
-appendInstallDir :: String -> IO String
-appendInstallDir cmd =
- case ghcToolDir of
- "" -> return cmd
- _ -> return (unwords [cmd, '-':'B':ghcToolDir])
-
--- convert filepath into MSDOS form.
-dosifyPath :: String -> String
-#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
-dosifyPath stuff = subst '/' '\\' real_stuff
- where
- -- fully convince myself that /cygdrive/ prefixes cannot
- -- really appear here.
- cygdrive_prefix = "/cygdrive/"
-
- real_stuff
- | "/cygdrive/" `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
- | otherwise = stuff
-
- subst a b ls = map (\ x -> if x == a then b else x) ls
-#else
-dosifyPath x = x
-#endif
-
-#ifdef mingw32_TARGET_OS
-foreign import "_getpid" myGetProcessID :: IO Int
-#else
-myGetProcessID :: IO Int
-myGetProcessID = Posix.getProcessID
-#endif
import CmStaticInfo
import DriverPhases
import DriverState
-import DriverUtil
import Module
-import FiniteMap
import FastString
-import Util
-import Panic ( panic )
import Config
import IOExts
{-# OPTIONS -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.69 2001/06/13 10:25:37 simonmar Exp $
+-- $Id: Main.hs,v 1.70 2001/06/14 12:50:06 simonpj Exp $
--
-- GHC Driver program
--
#ifdef GHCI
-import InteractiveUI
+import InteractiveUI(ghciWelcomeMsg, interactiveUI)
#endif
-#ifndef mingw32_TARGET_OS
-import Dynamic
-import Posix
-#endif
-import CompManager
-import ParsePkgConf
-import DriverPipeline
-import DriverState
-import DriverFlags
-import DriverMkDepend
-import DriverUtil
-import Panic
-import DriverPhases ( Phase(..), haskellish_src_file, objish_file )
-import CmdLineOpts
-import TmpFiles
import Finder ( initFinder )
-import CmStaticInfo
-import Config
+import CompManager ( cmInit, cmLoadModule )
+import CmStaticInfo ( GhciMode(..), PackageConfig(..) )
+import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion )
+import SysTools ( packageConfigPath, initSysTools, cleanTempFiles )
+import ParsePkgConf ( parsePkgConf )
+
+import DriverPipeline ( GhcMode(..), doLink, doMkDLL, genPipeline,
+ getGhcMode, pipeLoop, v_GhcMode
+ )
+import DriverState ( buildCoreToDo, buildStgToDo, defaultHscLang,
+ findBuildTag, getPackageInfo, unregFlags, v_Cmdline_libraries,
+ v_Keep_tmp_files, v_Ld_inputs, v_OptLevel, v_Output_file,
+ v_Output_hi, v_Package_details, v_Ways
+ )
+import DriverFlags ( dynFlag, buildStaticHscOpts, dynamic_flags, processArgs, static_flags)
+
+import DriverMkDepend ( beginMkDependHS, endMkDependHS )
+import DriverPhases ( Phase(Hsc, HCc), haskellish_src_file, objish_file )
+
+import DriverUtil ( add, handle, handleDyn, later, splitFilename, unknownFlagErr, my_prefix_match )
+import CmdLineOpts ( dynFlag,
+ DynFlags(verbosity, stgToDo, hscOutName, hscLang, coreToDo),
+ HscLang(HscInterpreted, HscC),
+ defaultDynFlags, restoreDynFlags, saveDynFlags, setDynFlags,
+ v_Static_hsc_opts
+ )
+
import Outputable
import Util
+import Panic ( GhcException(..), panic )
-import Concurrent
-import Directory
-import IOExts
-import Exception
-
+-- Standard Haskell libraries
import IO
+import Concurrent ( myThreadId, throwTo )
+import Directory ( doesFileExist )
+import IOExts ( readIORef, writeIORef )
+import Exception ( throwTo, throwDyn, Exception(DynException) )
+import System ( getArgs, exitWith, ExitCode(..) )
+
+#ifndef mingw32_TARGET_OS
+import Posix ( Handler(Catch), installHandler, sigINT, sigQUIT )
+import Dynamic ( toDyn )
+#endif
+
import Monad
import List
-import System
import Maybe
argv <- getArgs
-- grab any -B options from the command line first
- argv' <- setTopDir argv
- top_dir <- readIORef v_TopDir
-
- let installed s = top_dir ++ '/':s
- inplace s = top_dir ++ '/':cCURRENT_DIR ++ '/':s
-
- installed_pkgconfig = installed ("package.conf")
- inplace_pkgconfig = inplace (cGHC_DRIVER_DIR ++ "/package.conf.inplace")
-
- -- 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
-
- if am_installed
- then writeIORef v_Path_package_config installed_pkgconfig
- else do am_inplace <- doesFileExist inplace_pkgconfig
- if am_inplace
- then writeIORef v_Path_package_config inplace_pkgconfig
- else throwDyn (InstallationError
- ("Can't find package.conf in " ++
- inplace_pkgconfig))
-
- -- set the location of our various files
- if am_installed
- then do writeIORef v_Path_usage (installed "ghc-usage.txt")
- writeIORef v_Pgm_L (installed "unlit")
- writeIORef v_Pgm_m (installed "ghc-asm")
- writeIORef v_Pgm_s (installed "ghc-split")
-#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
- writeIORef v_Pgm_T (installed cTOUCH)
-#endif
+ let (top_dir, argv') = getTopDir argv
- else do writeIORef v_Path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
- writeIORef v_Pgm_L (inplace cGHC_UNLIT)
- writeIORef v_Pgm_m (inplace cGHC_MANGLER)
- writeIORef v_Pgm_s (inplace cGHC_SPLIT)
-#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
- writeIORef v_Pgm_T (inplace cTOUCH)
-#endif
+ initSysTools top_dir
-- read the package configuration
- conf_file <- readIORef v_Path_package_config
- r <- parsePkgConf conf_file
+ conf_file <- packageConfigPath
+ r <- parsePkgConf conf_file
case r of {
Left err -> throwDyn (InstallationError (showSDoc err));
Right pkg_details -> do
_other | opt_level >= 1 -> HscC -- -O implies -fvia-C
| otherwise -> defaultHscLang
- writeIORef v_DynFlags
- defaultDynFlags{ coreToDo = core_todo,
- stgToDo = stg_todo,
- hscLang = lang,
- -- leave out hscOutName for now
- hscOutName = panic "Main.main:hscOutName not set",
+ setDynFlags (defaultDynFlags{ coreToDo = core_todo,
+ stgToDo = stg_todo,
+ hscLang = lang,
+ -- leave out hscOutName for now
+ hscOutName = panic "Main.main:hscOutName not set",
- verbosity = case mode of
- DoInteractive -> 1
- DoMake -> 1
- _other -> 0,
- }
+ verbosity = case mode of
+ DoInteractive -> 1
+ DoMake -> 1
+ _other -> 0,
+ })
-- the rest of the arguments are "dynamic"
srcs <- processArgs dynamic_flags (way_non_static ++ non_static) []
+
-- save the "initial DynFlags" away
- init_dyn_flags <- readIORef v_DynFlags
- writeIORef v_InitDynFlags init_dyn_flags
+ saveDynFlags
-- complain about any unknown flags
mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
if null srcs then throwDyn (UsageError "no input files") else do
let compileFile src = do
- writeIORef v_DynFlags init_dyn_flags
+ restoreDynFlags
exists <- doesFileExist src
when (not exists) $
basename suffix
-- rest of compilation
- dyn_flags <- readIORef v_DynFlags
- phases <- genPipeline mode stop_flag True (hscLang dyn_flags) pp
+ hsc_lang <- dynFlag hscLang
+ phases <- genPipeline mode stop_flag True hsc_lang pp
r <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL) True{-use -o flag-}
basename suffix
return r
when (mode == DoMkDLL) (doMkDLL o_files)
}
-
--- grab the last -B option on the command line, and
--- set topDir to its value.
-setTopDir :: [String] -> IO [String]
-setTopDir args = do
- let (minusbs, others) = partition (prefixMatch "-B") args
- (case minusbs of
- [] -> throwDyn (InstallationError ("missing -B<dir> option"))
- some -> writeIORef v_TopDir (drop 2 (last some)))
- return others
+ -- 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
--- /dev/null
+-----------------------------------------------------------------------------
+-- 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 ()
+
+ -- Temporary-file management
+ setTmpDir,
+ newTempName,
+ cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
+ addFilesToClean,
+
+ -- System interface
+ getProcessID, -- IO Int
+ system, -- String -> IO Int -- System.system
+
+ -- Misc
+ showGhcUsage, -- IO () Shows usage message and exits
+ getSysMan, -- IO String Parallel system only
+
+ runSomething -- ToDo: make private
+ ) where
+
+import DriverUtil
+import Config
+import Outputable ( panic )
+import Panic ( progName, GhcException(..) )
+import Util ( global )
+import CmdLineOpts ( dynFlag, verbosity )
+
+import List ( intersperse )
+import Exception ( throwDyn, catchAllIO )
+import IO ( 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"
+#include "HsVersions.h"
+
+{-# DEPRECATED runSomething "runSomething should be private to SysTools" #-}
+
+\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)
+
+
+
+%************************************************************************
+%* *
+\subsection{Global variables to contain system programs}
+%* *
+%************************************************************************
+
+\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_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
+
+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}
+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
+
+ -> IO () -- Set all the mutable variables above, holding
+ -- (a) the system programs
+ -- (b) the package-config file
+ -- (c) the GHC usage message
+
+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"
+
+ -- 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
+
+ -- 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
+
+ -- 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"
+
+
+#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
+ ; let cpp_path | am_installed = installed cRAWCPP
+ | otherwise = cRAWCPP
+ gcc_path | am_installed = installed cGCC
+ | otherwise = cGCC
+ perl_path | am_installed = installed cGHC_PERL
+ | otherwise = cGHC_PERL
+
+ -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
+ ; let touch_path | am_installed = installed cGHC_TOUCHY
+ | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
+
+ ; 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 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"
+#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
+
+ split_path = perl_path ++ " " ++ split_script
+ mangle_path = perl_path ++ " " ++ mangle_script
+
+ -- 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
+
+
+ -- 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
+ ; writeIORef v_Pgm_PERL perl_path
+
+ }
+\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}
+
+
+%************************************************************************
+%* *
+\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 ()
+copy purpose from to = do p <- readIORef v_Pgm_CP
+ runSomething purpose p [from,to]
+\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
+ ; System.exitWith System.ExitSuccess }
+ 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
+%* *
+%************************************************************************
+
+One reason this code is here is because SysTools.system needs to make
+a temporary file.
+
+\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: " ++ concat (intersperse " " fs))
+ (mapM_ rm fs)
+ where
+ rm f = removeFile f `catchAllIO`
+ (\exn -> hPutStrLn stderr ("Warning: deleting non-existent " ++ f) >>
+ return ())
+
+\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
+ -- runSomthing will dos-ify them
+ -> IO ()
+
+runSomething phase_name pgm args
+ = traceCmd phase_name cmd_line $
+ do { exit_code <- system cmd_line
+ ; if exit_code /= ExitSuccess
+ then throwDyn (PhaseFailed phase_name exit_code)
+ else return ()
+ }
+ where
+ cmd_line = unwords (pgm : dosifyPaths args)
+
+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{Support code}
+%* *
+%************************************************************************
+
+
+\begin{code}
+-----------------------------------------------------------------------------
+-- Convert filepath into MSDOS form.
+
+dosifyPaths :: [String] -> [String]
+-- dosifyPath does two things
+-- a) change '/' to '\'
+-- b) remove initial '/cygdrive/'
+
+#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
+dosifyPaths xs = map dosifyPath xs
+
+dosifyPath :: String -> String
+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
+
+ subst a b ls = map (\ x -> if x == a then b else x) ls
+#else
+dosifyPaths xs = xs
+#endif
+
+-----------------------------------------------------------------------------
+-- Path name construction
+-- At the moment, we always use '/' and rely on dosifyPath
+-- to switch to DOS pathnames when necessary
+
+slash :: String -> String -> String
+absPath, relPath :: [String] -> String
+
+slash s1 s2 = s1 ++ ('/' : s2)
+
+
+relPath [] = ""
+relPath xs = foldr1 slash xs
+
+absPath xs = "" `slash` relPath xs
+
+-----------------------------------------------------------------------------
+-- Convert filepath into MSDOS form.
+--
+-- Define myGetProcessId :: IO Int
+
+#ifdef mingw32_TARGET_OS
+foreign import "_getpid" getProcessID :: IO Int
+#else
+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}
+++ /dev/null
------------------------------------------------------------------------------
--- $Id: TmpFiles.hs,v 1.22 2001/06/13 15:50:25 rrt Exp $
---
--- Temporary file management
---
--- (c) The University of Glasgow 2000
---
------------------------------------------------------------------------------
-
-module TmpFiles (
- Suffix,
- initTempFileStorage, -- :: IO ()
- cleanTempFiles, -- :: Int -> IO ()
- cleanTempFilesExcept, -- :: Int -> [FilePath] -> IO ()
- newTempName, -- :: Suffix -> IO FilePath
- addFilesToClean, -- :: [FilePath] -> IO ()
- removeTmpFiles, -- :: Int -> [FilePath] -> IO ()
- v_TmpDir
- ) where
-
--- main
-import DriverUtil
-import Config
-import Panic
-import Util
-
--- hslibs
-import Exception
-import IOExts
-
--- std
-import System
-import Directory
-import IO
-import Monad
-
-#include "../includes/config.h"
-#include "HsVersions.h"
-
-GLOBAL_VAR(v_FilesToClean, [], [String] )
-GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
-
-
-initTempFileStorage = do
- -- check whether TMPDIR is set in the environment
- IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
-#ifndef mingw32_TARGET_OS
- writeIORef v_TmpDir dir
-#endif
- return ()
- )
-
-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
-
-type Suffix = String
-
--- find a temporary name that doesn't already exist.
-newTempName :: Suffix -> IO FilePath
-newTempName extn = do
- x <- myGetProcessID
- 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 ()
-addFilesToClean files = mapM_ (add v_FilesToClean) files
-
-removeTmpFiles :: Int -> [FilePath] -> IO ()
-removeTmpFiles verb fs = do
- let verbose = verb >= 2
- blowAway f =
- (do when verbose (hPutStrLn stderr ("Removing: " ++ f))
- if '*' `elem` f
-#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
- then system (unwords [cRM, dosifyPath f]) >> return ()
-#else
- then system (unwords [cRM, f]) >> return ()
-#endif
- else removeFile f)
- `catchAllIO`
- (\_ -> when verbose (hPutStrLn stderr
- ("Warning: can't remove tmp file " ++ f)))
- mapM_ blowAway fs
# -----------------------------------------------------------------------------
-# $Id: paths.mk,v 1.31 2001/05/27 23:55:07 sof Exp $
+# $Id: paths.mk,v 1.32 2001/06/14 12:50:07 simonpj Exp $
#
# ghc project specific make variables
#
#-----------------------------------------------------------------------------
# Extra things ``only for'' for the ghc project
+# These are all build-time things
-GHC_DRIVER_DIR := $(TOP)/driver
+GHC_INCLUDE_DIR := $(TOP)/includes
GHC_COMPILER_DIR := $(TOP)/compiler
GHC_RUNTIME_DIR := $(TOP)/rts
GHC_LIB_DIR := $(TOP)/lib
-GHC_INCLUDE_DIR := $(TOP)/includes
-GHC_UTILS_DIR := $(TOP)/utils
GHC_INTERPRETER_DIR := $(TOP)/interpreter
-GHC_UNLIT_DIR := $(GHC_UTILS_DIR)/unlit
-GHC_TOUCHY_DIR := $(GHC_UTILS_DIR)/touchy
-GHC_MANGLER_DIR := $(GHC_DRIVER_DIR)/mangler
-GHC_SPLIT_DIR := $(GHC_DRIVER_DIR)/split
+# ---------------------------------------------------
+# -- These variables are defined primarily so they can
+# -- be spat into Config.hs by ghc/compiler/Makefile
+#
+# -- See comments in ghc/compiler/main/SysTools.lhs
+
+
+PROJECT_DIR := ghc
+GHC_DRIVER_DIR := $(PROJECT_DIR)/driver
+GHC_UTILS_DIR := $(PROJECT_DIR)/utils
+
+GHC_TOUCHY_DIR = $(GHC_UTILS_DIR)/touchy
+
+GHC_UNLIT_DIR = $(GHC_UTILS_DIR)/unlit
+GHC_UNLIT = unlit$(EXE_SUFFIX)
+
+GHC_MANGLER_DIR = $(GHC_DRIVER_DIR)/mangler
+GHC_MANGLER = ghc-asm
-GHC_UNLIT = $(GHC_UNLIT_DIR)/unlit$(EXE_SUFFIX)
-GHC_TOUCHY = $(GHC_TOUCHY_DIR)/touchy$(EXE_SUFFIX)
-GHC_MANGLER = $(GHC_MANGLER_DIR)/ghc-asm
-GHC_SPLIT = $(GHC_SPLIT_DIR)/ghc-split
+GHC_SPLIT_DIR = $(GHC_DRIVER_DIR)/split
+GHC_SPLIT = ghc-split
GHC_SYSMAN = $(GHC_RUNTIME_DIR)/parallel/SysMan
GHC_SYSMAN_DIR = $(GHC_RUNTIME_DIR)/parallel
+
+ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
+
+GHC_CP = "copy /y"
+GHC_PERL = perl
+GHC_TOUCHY = touchy$(EXE_SUFFIX)
+cGHC_RAWCPP = $(subst -mwin32,,$(RAWCPP))
+# Don't know why we do this...
+
+else
+
+GHC_CP = $(CP)
+GHC_PERL = $(PERL)
+GHC_TOUCHY = touch
+GHC_RAWCPP = $(RAWCPP)
+
+endif
+
projects / ghc-hetmet.git / commitdiff