import ForeignCall
-- Utils
+import DynFlags ( DynFlags, DynFlag(..), dopt )
import Unique ( getUnique )
import UniqSet
import FiniteMap
import FastString
import Outputable
import Constants
-import StaticFlags ( opt_SplitObjs )
-- The rest
import Data.List ( intersperse, groupBy )
-- --------------------------------------------------------------------------
-- 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
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 )
\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,
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
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
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}
-- 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
| 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
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
getOpts, -- (DynFlags -> [a]) -> IO [a]
getVerbFlag,
updOptLevel,
+ setTmpDir,
-- parsing DynFlags
parseDynamicFlags,
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 )
libraryPaths :: [String],
frameworkPaths :: [String], -- used on darwin only
cmdlineFrameworks :: [String], -- ditto
- tmpDir :: String,
+ tmpDir :: String, -- no trailing '/'
-- options for particular phases
opt_L :: [String],
libraryPaths = [],
frameworkPaths = [],
cmdlineFrameworks = [],
- tmpDir = [],
+ tmpDir = cDEFAULT_TMPDIR,
opt_L = [],
opt_P = [],
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.
, ( "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.
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
| 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
+
opt_IgnoreDotGhci,
opt_ErrorSpans,
opt_EmitCExternDecls,
- opt_SplitObjs,
opt_GranMacros,
opt_HiVersion,
opt_HistorySize,
------- 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") )
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
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
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 )
| 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
; 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 = "",
\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
-- 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
; 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
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
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 [] []
replaceFilenameSuffix, directoryOf, filenameOf,
replaceFilenameDirectory,
escapeSpaces, isPathSeparator,
+ normalisePath, platformPath, pgmPath,
) where
#include "HsVersions.h"
#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}
projects / ghc-hetmet.git / commitdiff