From 16d5d1c75c999677783c9c1bda519540fa9a6e58 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 14 Jun 2001 12:50:07 +0000 Subject: [PATCH] [project @ 2001-06-14 12:50:05 by simonpj] ---------------------- Installation packaging ---------------------- GHC runs various system programs like cp, touch gcc, as, ld etc On Windows we plan to deliver these programs along with GHC, so we have to be careful about where to find them. This commit isolates all these dependencies in a single module main/SysTools.lhs Most of the #ifdefery for mingw has moved into this module. There's some documentation in SysTools.lhs Along the way I did lots of other cleanups. In particular * There is no more 'globbing' needed when calling runSomething * All file removal goes via the standard Directory.removeFile * TmpFiles.hs has gone; absorbed into SysTools * Some DynFlag stuff has moved from DriverFlags to CmdLineOpts Still to do: ** I'm a bit concerned that calling removeFile one at a time when deleting masses of split-object files is going to be rather slow ** GHC now expects to find split,mangle,unlit in libdir/extra-bin instead of just libdir So something needs to change in the Unix installation scripts ** The "ineffective C preprocessor" is a perversion and should die --- ghc/compiler/HsVersions.h | 2 +- ghc/compiler/Makefile | 41 +-- ghc/compiler/basicTypes/Var.lhs | 2 + ghc/compiler/compMan/CmLink.lhs | 6 +- ghc/compiler/compMan/CompManager.lhs | 2 +- ghc/compiler/ghci/InteractiveUI.hs | 20 +- ghc/compiler/main/CmdLineOpts.lhs | 103 +++++-- ghc/compiler/main/DriverFlags.hs | 165 +++------- ghc/compiler/main/DriverMkDepend.hs | 17 +- ghc/compiler/main/DriverPipeline.hs | 279 +++++++---------- ghc/compiler/main/DriverState.hs | 30 +- ghc/compiler/main/DriverUtil.hs | 90 +----- ghc/compiler/main/Finder.lhs | 4 - ghc/compiler/main/Main.hs | 160 +++++----- ghc/compiler/main/SysTools.lhs | 564 ++++++++++++++++++++++++++++++++++ ghc/compiler/main/TmpFiles.hs | 98 ------ ghc/mk/paths.mk | 53 +++- 17 files changed, 964 insertions(+), 672 deletions(-) create mode 100644 ghc/compiler/main/SysTools.lhs delete mode 100644 ghc/compiler/main/TmpFiles.hs diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index abcaa99..39285ba 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -12,7 +12,7 @@ you will screw up the layout where they are used in case expressions! #ifdef __GLASGOW_HASKELL__ #define GLOBAL_VAR(name,value,ty) \ -name = global (value) :: IORef (ty); \ +name = Util.global (value) :: IORef (ty); \ {-# NOINLINE name #-} #endif diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index ecc6cd6..7cb9b0e 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $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 @@ -25,6 +25,9 @@ endif # ----------------------------------------------------------------------------- # 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 @@ -41,41 +44,31 @@ $(CONFIG_HS) : $(FPTOOLS_TOP)/mk/config.mk Makefile @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) @@ -250,7 +243,7 @@ main/DriverPipeline_HC_OPTS = -fno-cse 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 diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 80eb490..2362229 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -104,6 +104,8 @@ LocalId and GlobalId 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)) diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 9371eb4..f22f2de 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -35,9 +35,8 @@ import FiniteMap import Outputable import ErrUtils ( showPass ) import CmdLineOpts ( DynFlags(..) ) -import Panic ( panic, GhcException(..) ) +import Panic ( panic ) -import Exception import List import Monad import IO @@ -219,9 +218,6 @@ link' Interactive dflags batch_attempt_linking linkables pls 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) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 56d8325..144144e 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -55,8 +55,8 @@ import UniqFM 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(..) ) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index d0bc03c..2bf39b5 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -24,7 +24,7 @@ import Finder ( flushPackageCache ) 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 @@ -302,7 +302,7 @@ runStmt stmt = 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} @@ -396,7 +396,7 @@ defineMacro s = do -- 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 @@ -427,7 +427,7 @@ loadModule path = timeIt (loadModule' path) 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. @@ -464,7 +464,7 @@ modulesLoadedMsg ok mods = do 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 @@ -513,11 +513,9 @@ setOptions str -- 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: " ++ @@ -572,7 +570,7 @@ optToStr RevertCAFs = "r" newPackages new_pkgs = do state <- getGHCiState - dflags <- io (getDynFlags) + dflags <- io getDynFlags cmstate1 <- io (cmUnload (cmstate state) dflags) setGHCiState state{ cmstate = cmstate1, target = Nothing } diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 406e1d0..181863f 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -14,7 +14,6 @@ module CmdLineOpts ( HscLang(..), DynFlag(..), -- needed non-abstractly by DriverFlags DynFlags(..), - defaultDynFlags, v_Static_hsc_opts, @@ -22,26 +21,35 @@ module CmdLineOpts ( 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, @@ -108,7 +116,7 @@ module CmdLineOpts ( 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 @@ -312,6 +320,14 @@ data DynFlags = DynFlags { flags :: [DynFlag] } +data HscLang + = HscC + | HscAsm + | HscJava + | HscILX + | HscInterpreted + deriving (Eq, Show) + defaultDynFlags = DynFlags { coreToDo = [], stgToDo = [], hscLang = HscC, @@ -353,24 +369,61 @@ dopt_StgToDo = stgToDo 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} diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 50692f0..f7a48ed 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# 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 -- @@ -11,10 +11,9 @@ module DriverFlags ( processArgs, OptKind(..), static_flags, dynamic_flags, - v_InitDynFlags, v_DynFlags, getDynFlags, dynFlag, + getDynFlags, dynFlag, getOpts, getVerbFlag, addCmdlineHCInclude, buildStaticHscOpts, - runSomething, machdepCCOpts ) where @@ -22,7 +21,7 @@ module DriverFlags ( import DriverState import DriverUtil -import TmpFiles ( v_TmpDir ) +import SysTools ( setTmpDir, setPgm, setDryRun, showGhcUsage ) import CmdLineOpts import Config import Util @@ -30,11 +29,11 @@ import Panic import Exception import IOExts +import System ( exitWith, ExitCode(..) ) import IO import Maybe import Monad -import System import Char ----------------------------------------------------------------------------- @@ -71,15 +70,15 @@ data OptKind | 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) @@ -127,7 +126,8 @@ processOneArg action rest (dash_arg@('-':arg):args) = 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 @@ -152,8 +152,8 @@ arg_ok (AnySuffixPred p _) rest arg = p arg static_flags = [ ------- help ------------------------------------------------------- - ( "?" , NoArg long_usage) - , ( "-help" , NoArg long_usage) + ( "?" , NoArg showGhcUsage) + , ( "-help" , NoArg showGhcUsage) ------- version ---------------------------------------------------- @@ -164,7 +164,7 @@ static_flags = exitWith ExitSuccess)) ------- verbosity ---------------------------------------------------- - , ( "n" , NoArg (writeIORef v_Dry_run True) ) + , ( "n" , NoArg setDryRun ) ------- recompilation checker -------------------------------------- , ( "recomp" , NoArg (writeIORef v_Recomp True) ) @@ -210,7 +210,7 @@ static_flags = , ( "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? @@ -242,13 +242,7 @@ static_flags = , ( "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) ) @@ -293,73 +287,6 @@ static_flags = , ( "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)") - -getVerbFlag = do - verb <- dynFlag verbosity - if verb >= 3 then return "-v" else return "" - dynamic_flags = [ ( "cpp", NoArg (updDynFlags (\s -> s{ cppFlag = True })) ) @@ -488,8 +415,6 @@ decodeSize str n = read m :: Double pred c = isDigit c || c == '.' -floatOpt :: IORef Double -> String -> IO () -floatOpt ref str = writeIORef ref (read str :: Double) ----------------------------------------------------------------------------- -- RTS Hooks @@ -527,30 +452,6 @@ buildStaticHscOpts = do 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 @@ -599,3 +500,35 @@ machdepCCOpts | 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)") + +getVerbFlag = do + verb <- dynFlag verbosity + if verb >= 3 then return "-v" else return "" diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index 64c99bb..948dbf1 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -14,7 +14,8 @@ module DriverMkDepend where import DriverState import DriverUtil import DriverFlags -import TmpFiles +import SysTools ( newTempName ) +import qualified SysTools import Module import Config import Util @@ -158,14 +159,12 @@ endMkDependHS = do 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)) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index e2bddc4..2ff3078 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -34,8 +34,9 @@ import DriverUtil import DriverMkDepend import DriverPhases import DriverFlags +import SysTools ( newTempName, addFilesToClean, getSysMan ) +import qualified SysTools import HscMain -import TmpFiles import Finder import HscTypes import Outputable @@ -308,13 +309,8 @@ pipeLoop ((phase, keep, o_suffix):phases) -- 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 ------------------------------------------------------------------------------- @@ -328,8 +324,7 @@ run_phase Cpp basename suff input_fn output_fn 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 @@ -340,15 +335,13 @@ run_phase Cpp basename suff input_fn output_fn 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) @@ -362,10 +355,10 @@ run_phase Cpp basename suff input_fn output_fn (\_ -> 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 @@ -374,7 +367,7 @@ run_phase Cpp basename suff input_fn output_fn 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 @@ -500,7 +493,7 @@ run_phase Hsc basename suff input_fn output_fn 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", @@ -523,16 +516,8 @@ run_phase Hsc basename suff input_fn output_fn 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 @@ -554,8 +539,7 @@ run_phase Hsc basename suff input_fn output_fn 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 @@ -583,20 +567,19 @@ run_phase cc_phase basename suff input_fn output_fn | 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 @@ -605,97 +588,67 @@ run_phase cc_phase basename suff input_fn output_fn -- 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 @@ -713,13 +666,12 @@ run_phase SplitAs basename _suff _input_fn _output_fn 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 @@ -799,10 +751,8 @@ checkProcessArgsResult flags basename suff 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 @@ -815,7 +765,8 @@ doLink o_files = do 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) @@ -831,53 +782,39 @@ doLink o_files = do 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 @@ -890,7 +827,8 @@ doMkDLL o_files = do 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) @@ -906,22 +844,19 @@ doMkDLL o_files = do 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 @@ -933,7 +868,6 @@ doMkDLL o_files = do Just _ -> [ "" ]) ++ extra_ld_opts ) - ) ----------------------------------------------------------------------------- -- Just preprocess a file, put the result in a temp. file (used by the @@ -942,10 +876,9 @@ doMkDLL o_files = do 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-} ----------------------------------------------------------------------------- @@ -987,13 +920,13 @@ data CompResult 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) @@ -1002,9 +935,9 @@ compile ghci_mode summary source_unchanged have_object 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 diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 8cad99c..06e23e5 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -19,10 +19,6 @@ import Util import Config import Exception import IOExts -#ifdef mingw32_TARGET_OS -import TmpFiles ( newTempName ) -import Directory ( removeFile ) -#endif import Panic import List @@ -37,9 +33,6 @@ cHaskell1Version = "5" -- i.e., Haskell 98 ----------------------------------------------------------------------------- -- 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 @@ -58,7 +51,6 @@ GLOBAL_VAR(v_Keep_tmp_files, False, Bool) -- 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) @@ -70,8 +62,9 @@ GLOBAL_VAR(v_Excess_precision, False, 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 @@ -326,8 +319,6 @@ GLOBAL_VAR(v_HCHeader, "", String) ----------------------------------------------------------------------------- -- 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]) @@ -590,19 +581,6 @@ unregFlags = ----------------------------------------------------------------------------- -- 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]) diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index 210acdb..77c0f4c 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -22,30 +22,14 @@ import RegexString 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 @@ -96,8 +80,8 @@ my_partition p (a:as) 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 @@ -132,14 +116,20 @@ addNoDups var x = do 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 @@ -147,7 +137,7 @@ splitFilename3 str | 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 @@ -171,7 +161,7 @@ split_longest_prefix s c (_: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. @@ -186,55 +176,3 @@ remove_spaces :: String -> String 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 diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 6cb1fc9..65fbb2e 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -19,12 +19,8 @@ import HscTypes ( ModuleLocation(..) ) import CmStaticInfo import DriverPhases import DriverState -import DriverUtil import Module -import FiniteMap import FastString -import Util -import Panic ( panic ) import Config import IOExts diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index f65ed50..57f7d3d 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.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 -- @@ -17,40 +17,57 @@ module Main (main) where #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 @@ -120,49 +137,13 @@ main = 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 @@ -223,24 +204,23 @@ main = _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 ] @@ -286,7 +266,7 @@ main = 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) $ @@ -305,8 +285,8 @@ main = 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 @@ -318,16 +298,14 @@ main = 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 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 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 diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs new file mode 100644 index 0000000..4e8c0bb --- /dev/null +++ b/ghc/compiler/main/SysTools.lhs @@ -0,0 +1,564 @@ +----------------------------------------------------------------------------- +-- 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} diff --git a/ghc/compiler/main/TmpFiles.hs b/ghc/compiler/main/TmpFiles.hs deleted file mode 100644 index 3c50aec..0000000 --- a/ghc/compiler/main/TmpFiles.hs +++ /dev/null @@ -1,98 +0,0 @@ ------------------------------------------------------------------------------ --- $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 diff --git a/ghc/mk/paths.mk b/ghc/mk/paths.mk index 65faaed..5f6db64 100644 --- a/ghc/mk/paths.mk +++ b/ghc/mk/paths.mk @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $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 # @@ -16,24 +16,53 @@ endif #----------------------------------------------------------------------------- # 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 + -- 1.7.10.4