diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index abcaa994c975d9663365e2ef47d3a22613b50e7c..39285ba3de62e0759acd2abb73df897ad83c4dee 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 ecc6cd6fb9a5154ac437ce988311f818ec5a9073..7cb9b0e7aaf90d52241ffcc923fdbaab87411b61 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 80eb490ccfa45d985b555a8ed17df3c69eae2961..23622292abe1c6c64dd18d7f23ad08cbafb29ce2 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 9371eb446b851b36d01a23b0dd2dd87d51a1c0d0..f22f2dec5b3a72cc280c48e2a0b7ea114baba36c 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 56d8325c07a49dd71e4b96962154c6d5b0b0cade..144144e9b4dc6e21be2cdd466fd24a9f6d9f08e8 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 d0bc03c58ee71644773227c75dc5c2ca61c33f51..2bf39b5e89c5fe5dbf298beb5ce99186e3a509fc 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 406e1d02ce8b67de8f99c509ad793f91227fdab4..181863f66e6a0152a008295ddaaad31e25104bd9 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 50692f096e7a4dc2027c713954069ad6b886adcd..f7a48edb16c50f457b9013da48706ed0b36a814c 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 @@ -526,30 +451,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 @@ -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 64c99bba2c5ffbeb702469265661b17014b90b04..948dbf1a060de57ddf11b16ef10cb93839b33be7 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 e2bddc4d16a71e07257949fc0f01a1d9e5451cd9..2ff3078ec86e4c8c61d861a9a92c82944093f256 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 8cad99c887bb9b3ab2860cd7ce7b126981acf41a..06e23e5db5d7d9876809d6063635c30aa604cf88 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 210acdbd56cd85201ff511796692dbec5f66a9ca..77c0f4c637c1a70be67df16ec8861b23ef2a1d58 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 6cb1fc9ae1562691c655807e60fb1bb93de83595..65fbb2ee2b755a8660bc05d0d418a1ebcb359440 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 f65ed506433e93d4a00aa3b2f26902c0e850ca4f..57f7d3d9cfef31477f42dc9659680c95551c22d4 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 0000000000000000000000000000000000000000..4e8c0bb2d5739754fe04b2f6244c92b0827ca3db --- /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 3c50aec9ca1a07fe55ad6f3b591993e22c357c1c..0000000000000000000000000000000000000000 --- 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 65faaed9ebabfc8da7c010c40eee1a8b2492d688..5f6db64c6ae5891c5d36eaf52c6219c4766df05f 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 +