diff options
| -rw-r--r-- | ghc/compiler/cmm/PprC.hs | 24 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CodeGen.lhs | 14 | ||||
| -rw-r--r-- | ghc/compiler/main/CodeOutput.lhs | 2 | ||||
| -rw-r--r-- | ghc/compiler/main/DriverMkDepend.hs | 2 | ||||
| -rw-r--r-- | ghc/compiler/main/DriverPipeline.hs | 4 | ||||
| -rw-r--r-- | ghc/compiler/main/DynFlags.hs | 65 | ||||
| -rw-r--r-- | ghc/compiler/main/StaticFlags.hs | 26 | ||||
| -rw-r--r-- | ghc/compiler/main/SysTools.lhs | 114 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/AsmCodeGen.lhs | 6 | ||||
| -rw-r--r-- | ghc/compiler/utils/Util.lhs | 36 |
10 files changed, 141 insertions, 152 deletions
diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs index 04c8194d1f..02eb902b66 100644 --- a/ghc/compiler/cmm/PprC.hs +++ b/ghc/compiler/cmm/PprC.hs @@ -30,6 +30,7 @@ import MachOp import ForeignCall -- Utils +import DynFlags ( DynFlags, DynFlag(..), dopt ) import Unique ( getUnique ) import UniqSet import FiniteMap @@ -37,7 +38,6 @@ import UniqFM ( eltsUFM ) import FastString import Outputable import Constants -import StaticFlags ( opt_SplitObjs ) -- The rest import Data.List ( intersperse, groupBy ) @@ -59,16 +59,18 @@ import MONAD_ST -- -------------------------------------------------------------------------- -- Top level -pprCs :: [Cmm] -> SDoc -pprCs cmms = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms) - -writeCs :: Handle -> [Cmm] -> IO () -writeCs handle cmms = printForUser handle alwaysQualify (pprCs cmms) - -- ToDo: should be printForC - -split_marker - | opt_SplitObjs = ptext SLIT("__STG_SPLIT_MARKER") - | otherwise = empty +pprCs :: DynFlags -> [Cmm] -> SDoc +pprCs dflags cmms + = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms) + where + split_marker + | dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER") + | otherwise = empty + +writeCs :: DynFlags -> Handle -> [Cmm] -> IO () +writeCs dflags handle cmms + = printForUser handle alwaysQualify (pprCs dflags cmms) + -- ToDo: should be printForC -- -------------------------------------------------------------------------- -- Now do some real work diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index fa92421b21..11dafdd363 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -39,8 +39,8 @@ import MachOp ( wordRep, MachHint(..) ) import StgSyn import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER ) -import DynFlags ( DynFlags(..), DynFlag(..) ) -import StaticFlags ( opt_SplitObjs, opt_SccProfilingOn ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt ) +import StaticFlags ( opt_SccProfilingOn ) import HscTypes ( ForeignStubs(..), TypeEnv, typeEnvTyCons ) import CostCentre ( CollectedCCs ) @@ -281,7 +281,7 @@ variable. \begin{code} cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code cgTopBinding dflags (StgNonRec id rhs, srts) - = do { id' <- maybeExternaliseId id + = do { id' <- maybeExternaliseId dflags id ; mapM_ (mkSRT dflags [id']) srts ; (id,info) <- cgTopRhs id' rhs ; addBindC id info -- Add the *un-externalised* Id to the envt, @@ -290,7 +290,7 @@ cgTopBinding dflags (StgNonRec id rhs, srts) cgTopBinding dflags (StgRec pairs, srts) = do { let (bndrs, rhss) = unzip pairs - ; bndrs' <- mapFCs maybeExternaliseId bndrs + ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss ; mapM_ (mkSRT dflags bndrs') srts ; _new_binds <- fixC (\ new_binds -> do @@ -342,9 +342,9 @@ If we're splitting the object, we need to externalise all the top-level names which refers to this name). \begin{code} -maybeExternaliseId :: Id -> FCode Id -maybeExternaliseId id - | opt_SplitObjs, -- Externalise the name for -split-objs +maybeExternaliseId :: DynFlags -> Id -> FCode Id +maybeExternaliseId dflags id + | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs isInternalName name = do { mod <- moduleName ; returnFC (setIdName id (externalise mod)) } | otherwise = returnFC id diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 704a908d08..723227f030 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -152,7 +152,7 @@ outputC dflags filenm flat_absC hPutStr h cc_injects when stub_h_exists $ hPutStrLn h ("#include \"" ++ (filenameOf (hscStubHOutName dflags)) ++ "\"") - writeCs h flat_absC + writeCs dflags h flat_absC \end{code} diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index 3837d2cbdf..fe8ad3cd10 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -96,7 +96,7 @@ beginMkDependHS dflags = do -- open a new temp file in which to stuff the dependency info -- as we go along. - tmp_file <- newTempName "dep" + tmp_file <- newTempName dflags "dep" tmp_hdl <- openFile tmp_file WriteMode -- open the makefile diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 9ffc9db444..4c60264e92 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -410,7 +410,7 @@ genOutputFilenameFunc dflags stop_phase keep_final_output | is_last_phase, Just f <- maybe_output_filename = return f | is_last_phase && keep_final_output = persistent_fn | keep_this_output = persistent_fn - | otherwise = newTempName suffix + | otherwise = newTempName dflags suffix where is_last_phase = next_phase `eqPhase` stop_phase @@ -802,7 +802,7 @@ runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_loc = 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" + split_s_prefix <- SysTools.newTempName dflags "split" let n_files_fn = split_s_prefix SysTools.runSplit dflags diff --git a/ghc/compiler/main/DynFlags.hs b/ghc/compiler/main/DynFlags.hs index 62d269d1ba..e138f47c9e 100644 --- a/ghc/compiler/main/DynFlags.hs +++ b/ghc/compiler/main/DynFlags.hs @@ -37,6 +37,7 @@ module DynFlags ( getOpts, -- (DynFlags -> [a]) -> IO [a] getVerbFlag, updOptLevel, + setTmpDir, -- parsing DynFlags parseDynamicFlags, @@ -54,7 +55,7 @@ import DriverPhases ( Phase(..), phaseInputExt ) import Config import CmdLineParser import Panic ( panic, GhcException(..) ) -import Util ( notNull, splitLongestPrefix, split ) +import Util ( notNull, splitLongestPrefix, split, normalisePath ) import DATA_IOREF ( readIORef ) import EXCEPTION ( throwDyn ) @@ -213,7 +214,7 @@ data DynFlags = DynFlags { libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto - tmpDir :: String, + tmpDir :: String, -- no trailing '/' -- options for particular phases opt_L :: [String], @@ -342,7 +343,7 @@ defaultDynFlags = libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], - tmpDir = [], + tmpDir = cDEFAULT_TMPDIR, opt_L = [], opt_P = [], @@ -431,7 +432,6 @@ setObjectSuf f d = d{ objectSuf = f} setHcSuf f d = d{ hcSuf = f} setHiSuf f d = d{ hiSuf = f} setHiDir f d = d{ hiDir = f} -setTmpDir f d = d{ tmpDir = f} -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. @@ -769,6 +769,10 @@ dynamic_flags = [ , ( "optdll" , HasArg (upd . addOptdll) ) , ( "optdep" , HasArg (upd . addOptdep) ) + , ( "split-objs" , NoArg (if can_split + then setDynFlag Opt_SplitObjs + else return ()) ) + -------- Linking ---------------------------------------------------- , ( "c" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) , ( "no-link" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep. @@ -1118,6 +1122,40 @@ splitPathList s = filter notNull (splitUp s) dir_markers = ['/', '\\'] #endif +-- ----------------------------------------------------------------------------- +-- tmpDir, where we store temporary files. + +setTmpDir :: FilePath -> DynFlags -> DynFlags +setTmpDir dir dflags = dflags{ tmpDir = canonicalise dir } + where +#if !defined(mingw32_HOST_OS) + canonicalise p = normalisePath p +#else + -- Canonicalisation of temp path under win32 is a bit more + -- involved: (a) strip trailing slash, + -- (b) normalise slashes + -- (c) just in case, if there is a prefix /cygdrive/x/, change to x: + -- + canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path)) + + -- if we're operating under cygwin, and TMP/TEMP is of + -- the form "/cygdrive/drive/path", translate this to + -- "drive:/path" (as GHC isn't a cygwin app and doesn't + -- understand /cygdrive paths.) + xltCygdrive path + | "/cygdrive/" `isPrefixOf` path = + case drop (length "/cygdrive/") path of + drive:xs@('/':_) -> drive:':':xs + _ -> path + | otherwise = path + + -- strip the trailing backslash (awful, but we only do this once). + removeTrailingSlash path = + case last path of + '/' -> init path + '\\' -> init path + _ -> path +#endif ----------------------------------------------------------------------------- -- Via-C compilation stuff @@ -1228,3 +1266,22 @@ picCCOpts dflags | otherwise = [] #endif + +-- ----------------------------------------------------------------------------- +-- Splitting + +can_split :: Bool +can_split = +#if defined(i386_TARGET_ARCH) \ + || defined(alpha_TARGET_ARCH) \ + || defined(hppa_TARGET_ARCH) \ + || defined(m68k_TARGET_ARCH) \ + || defined(mips_TARGET_ARCH) \ + || defined(powerpc_TARGET_ARCH) \ + || defined(rs6000_TARGET_ARCH) \ + || defined(sparc_TARGET_ARCH) + True +#else + False +#endif + diff --git a/ghc/compiler/main/StaticFlags.hs b/ghc/compiler/main/StaticFlags.hs index 0bce0d19eb..0d01001403 100644 --- a/ghc/compiler/main/StaticFlags.hs +++ b/ghc/compiler/main/StaticFlags.hs @@ -58,7 +58,6 @@ module StaticFlags ( opt_IgnoreDotGhci, opt_ErrorSpans, opt_EmitCExternDecls, - opt_SplitObjs, opt_GranMacros, opt_HiVersion, opt_HistorySize, @@ -153,12 +152,6 @@ static_flags = [ ------- Miscellaneous ----------------------------------------------- , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat - , ( "split-objs" , NoArg (if can_split - then addOpt "-split-objs" - else hPutStrLn stderr - "warning: don't know how to split object files on this architecture" - ) ) - ----- Linker -------------------------------------------------------- , ( "static" , PassFlag addOpt ) , ( "dynamic" , NoArg (removeOpt "-static") ) @@ -278,7 +271,6 @@ opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int) opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) opt_EmitCExternDecls = lookUp FSLIT("-femit-extern-decls") -opt_SplitObjs = lookUp FSLIT("-split-objs") opt_GranMacros = lookUp FSLIT("-fgransim") opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Int opt_HistorySize = lookup_def_int "-fhistory-size" 20 @@ -399,24 +391,6 @@ foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO () foreign import "enableTimingStats" unsafe enableTimingStats :: IO () #endif --- ----------------------------------------------------------------------------- --- Splitting - -can_split :: Bool -can_split = -#if defined(i386_TARGET_ARCH) \ - || defined(alpha_TARGET_ARCH) \ - || defined(hppa_TARGET_ARCH) \ - || defined(m68k_TARGET_ARCH) \ - || defined(mips_TARGET_ARCH) \ - || defined(powerpc_TARGET_ARCH) \ - || defined(rs6000_TARGET_ARCH) \ - || defined(sparc_TARGET_ARCH) - True -#else - False -#endif - ----------------------------------------------------------------------------- -- Ways diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index 9710bcb96c..b18cd8a3bc 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -48,8 +48,10 @@ import DriverPhases ( isHaskellUserSrcFilename ) import Config import Outputable import Panic ( GhcException(..) ) -import Util ( Suffix, global, notNull, consIORef ) -import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..) ) +import Util ( Suffix, global, notNull, consIORef, + normalisePath, pgmPath, platformPath ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..), + setTmpDir, defaultDynFlags ) import EXCEPTION ( throwDyn ) import DATA_IOREF ( IORef, readIORef, writeIORef ) @@ -237,32 +239,32 @@ initSysTools minusB_args dflags | am_installed = installed_bin cGHC_MANGLER_PGM | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM + ; let dflags0 = defaultDynFlags #ifndef mingw32_HOST_OS -- check whether TMPDIR is set in the environment - ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set - setTmpDir dir - return () - ) + ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set #else -- On Win32, consult GetTempPath() for a temp dir. -- => it first tries TMP, TEMP, then finally the -- Windows directory(!). The directory is in short-path -- form. - ; IO.try (do + ; e_tmpdir <- + IO.try (do let len = (2048::Int) buf <- mallocArray len ret <- getTempPath len buf - tdir <- - if ret == 0 then do + if ret == 0 then do -- failed, consult TMPDIR. free buf getEnv "TMPDIR" - else do + else do s <- peekCString buf free buf - return s - setTmpDir tdir) + return s) #endif + ; let dflags1 = case e_tmpdir of + Left _ -> dflags0 + Right d -> setTmpDir d dflags0 -- Check that the package config exists ; config_exists <- doesFileExist pkgconfig_path @@ -364,7 +366,7 @@ initSysTools minusB_args dflags ; writeIORef v_Pgm_T touch_path ; writeIORef v_Pgm_CP cp_path - ; return dflags{ + ; return dflags1{ pgm_L = unlit_path, pgm_P = cpp_path, pgm_F = "", @@ -518,42 +520,9 @@ getUsageMsgPaths = readIORef v_Path_usages \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 (canonicalise dir) - where -#if !defined(mingw32_HOST_OS) - canonicalise p = normalisePath p -#else - -- Canonicalisation of temp path under win32 is a bit more - -- involved: (a) strip trailing slash, - -- (b) normalise slashes - -- (c) just in case, if there is a prefix /cygdrive/x/, change to x: - -- - canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path)) - - -- if we're operating under cygwin, and TMP/TEMP is of - -- the form "/cygdrive/drive/path", translate this to - -- "drive:/path" (as GHC isn't a cygwin app and doesn't - -- understand /cygdrive paths.) - xltCygdrive path - | "/cygdrive/" `isPrefixOf` path = - case drop (length "/cygdrive/") path of - drive:xs@('/':_) -> drive:':':xs - _ -> path - | otherwise = path - - -- strip the trailing backslash (awful, but we only do this once). - removeTrailingSlash path = - case last path of - '/' -> init path - '\\' -> init path - _ -> path -#endif - cleanTempFiles :: DynFlags -> IO () cleanTempFiles dflags = do fs <- readIORef v_FilesToClean @@ -569,10 +538,9 @@ cleanTempFilesExcept dflags dont_delete -- find a temporary name that doesn't already exist. -newTempName :: Suffix -> IO FilePath -newTempName extn +newTempName :: DynFlags -> Suffix -> IO FilePath +newTempName DynFlags{tmpDir=tmp_dir} extn = do x <- getProcessID - tmp_dir <- readIORef v_TmpDir findTempName tmp_dir x where findTempName tmp_dir x @@ -669,54 +637,6 @@ traceCmd dflags phase_name cmd_line action ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) } \end{code} - -%************************************************************************ -%* * -\subsection{Path names} -%* * -%************************************************************************ - -We maintain path names in Unix form ('/'-separated) right until -the last moment. On Windows we dos-ify them just before passing them -to the Windows command. - -The alternative, of using '/' consistently on Unix and '\' on Windows, -proved quite awkward. There were a lot more calls to platformPath, -and even on Windows we might invoke a unix-like utility (eg 'sh'), which -interpreted a command line 'foo\baz' as 'foobaz'. - -\begin{code} ------------------------------------------------------------------------------ --- Convert filepath into platform / MSDOS form. - -normalisePath :: String -> String --- Just changes '\' to '/' - -pgmPath :: String -- Directory string in Unix format - -> String -- Program name with no directory separators - -- (e.g. copy /y) - -> String -- Program invocation string in native format - - - -#if defined(mingw32_HOST_OS) ---------------------- Windows version ------------------ -normalisePath xs = subst '\\' '/' xs -platformPath p = subst '/' '\\' p -pgmPath dir pgm = platformPath dir ++ '\\' : pgm - -subst a b ls = map (\ x -> if x == a then b else x) ls -#else ---------------------- Non-Windows version -------------- -normalisePath xs = xs -pgmPath dir pgm = dir ++ '/' : pgm -platformPath stuff = stuff --------------------------------------------------------- -#endif - -\end{code} - - ----------------------------------------------------------------------------- Path name construction diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 2a7492b858..e7909913f9 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -37,7 +37,7 @@ import List ( groupBy, sortBy ) import CLabel ( pprCLabel ) import ErrUtils ( dumpIfSet_dyn ) import DynFlags ( DynFlags, DynFlag(..), dopt ) -import StaticFlags ( opt_Static, opt_SplitObjs, opt_PIC ) +import StaticFlags ( opt_Static, opt_PIC ) import Digraph import qualified Pretty @@ -133,8 +133,8 @@ nativeCodeGen dflags cmms us where add_split (Cmm tops) - | opt_SplitObjs = split_marker : tops - | otherwise = tops + | dopt Opt_SplitObjs dflags = split_marker : tops + | otherwise = tops split_marker = CmmProc [] mkSplitMarkerLabel [] [] diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index d3eb975694..d51a09d9ab 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -67,6 +67,7 @@ module Util ( replaceFilenameSuffix, directoryOf, filenameOf, replaceFilenameDirectory, escapeSpaces, isPathSeparator, + normalisePath, platformPath, pgmPath, ) where #include "HsVersions.h" @@ -923,4 +924,39 @@ isPathSeparator ch = #else ch == '/' #endif + +----------------------------------------------------------------------------- +-- Convert filepath into platform / MSDOS form. + +-- We maintain path names in Unix form ('/'-separated) right until +-- the last moment. On Windows we dos-ify them just before passing them +-- to the Windows command. +-- +-- The alternative, of using '/' consistently on Unix and '\' on Windows, +-- proved quite awkward. There were a lot more calls to platformPath, +-- and even on Windows we might invoke a unix-like utility (eg 'sh'), which +-- interpreted a command line 'foo\baz' as 'foobaz'. + +normalisePath :: String -> String +-- Just changes '\' to '/' + +pgmPath :: String -- Directory string in Unix format + -> String -- Program name with no directory separators + -- (e.g. copy /y) + -> String -- Program invocation string in native format + +#if defined(mingw32_HOST_OS) +--------------------- Windows version ------------------ +normalisePath xs = subst '\\' '/' xs +pgmPath dir pgm = platformPath dir ++ '\\' : pgm +platformPath p = subst '/' '\\' p + +subst a b ls = map (\ x -> if x == a then b else x) ls +#else +--------------------- Non-Windows version -------------- +normalisePath xs = xs +pgmPath dir pgm = dir ++ '/' : pgm +platformPath stuff = stuff +-------------------------------------------------------- +#endif \end{code} |