Commit 50159f6c authored by simonmar's avatar simonmar
Browse files

[project @ 2005-03-21 10:50:22 by simonmar]

Complete the transition of -split-objs into a dynamic flag (looks like I
half-finished it in the last commit).

Also: complete the transition of -tmpdir into a dynamic flag, which
involves some rearrangement of code from SysTools into DynFlags.

Someday, initSysTools should move wholesale into initDynFlags, because
most of the state that it initialises is now part of the DynFlags
structure, and the rest could be moved in easily.
parent cbe4c3a7
......@@ -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,17 +59,19 @@ import MONAD_ST
-- --------------------------------------------------------------------------
-- Top level
pprCs :: [Cmm] -> SDoc
pprCs cmms = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
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 :: Handle -> [Cmm] -> IO ()
writeCs handle cmms = printForUser handle alwaysQualify (pprCs cmms)
writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
writeCs dflags handle cmms
= printForUser handle alwaysQualify (pprCs dflags cmms)
-- ToDo: should be printForC
split_marker
| opt_SplitObjs = ptext SLIT("__STG_SPLIT_MARKER")
| otherwise = empty
-- --------------------------------------------------------------------------
-- Now do some real work
--
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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
......
......@@ -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,22 +239,20 @@ 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
-- failed, consult TMPDIR.
free buf
......@@ -260,9 +260,11 @@ initSysTools minusB_args dflags
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
......
......@@ -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,7 +133,7 @@ nativeCodeGen dflags cmms us
where
add_split (Cmm tops)
| opt_SplitObjs = split_marker : tops
| dopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops
split_marker = CmmProc [] mkSplitMarkerLabel [] []
......
......@@ -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}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment