X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDynFlags.hs;h=a7f02bf2c454a25d4af14cd1bd565c569450aa54;hb=f2e730f34ab0134391c88fe58f9f9e94b736da91;hp=62d269d1ba6cd5a1d476a735c7dd483f9a4bb154;hpb=d1c1b7d0e7b94ede238845c91f58582bad3b3ef3;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DynFlags.hs b/ghc/compiler/main/DynFlags.hs index 62d269d..a7f02bf 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, @@ -47,6 +48,8 @@ module DynFlags ( #include "HsVersions.h" +import Module ( Module, mkModule ) +import PrelNames ( mAIN ) import StaticFlags ( opt_Static, opt_PIC, WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag ) import {-# SOURCE #-} Packages (PackageState) @@ -54,13 +57,20 @@ import DriverPhases ( Phase(..), phaseInputExt ) import Config import CmdLineParser import Panic ( panic, GhcException(..) ) -import Util ( notNull, splitLongestPrefix, split ) +import Util ( notNull, splitLongestPrefix, split, normalisePath ) +import SrcLoc ( SrcSpan ) import DATA_IOREF ( readIORef ) import EXCEPTION ( throwDyn ) import Monad ( when ) +#ifdef mingw32_TARGET_OS +import Data.List ( isPrefixOf ) +#endif import Maybe ( fromJust ) import Char ( isDigit, isUpper ) +import Outputable +import System.IO ( hPutStrLn, stderr ) +import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) -- ----------------------------------------------------------------------------- -- DynFlags @@ -166,6 +176,7 @@ data DynFlag | Opt_NoHsMain | Opt_SplitObjs | Opt_StgStats + | Opt_HideAllPackages -- keeping stuff | Opt_KeepHiDiffs @@ -175,7 +186,7 @@ data DynFlag | Opt_KeepTmpFiles deriving (Eq) - + data DynFlags = DynFlags { ghcMode :: GhcMode, ghcLink :: GhcLink, @@ -183,8 +194,6 @@ data DynFlags = DynFlags { stgToDo :: Maybe [StgToDo], -- similarly hscTarget :: HscTarget, hscOutName :: String, -- name of the output file - hscStubHOutName :: String, -- name of the .stub_h output file - hscStubCOutName :: String, -- name of the .stub_c output file extCoreName :: String, -- name of the .core output file verbosity :: Int, -- verbosity level optLevel :: Int, -- optimisation level @@ -193,7 +202,7 @@ data DynFlags = DynFlags { stolen_x86_regs :: Int, cmdlineHcIncludes :: [String], -- -#includes importPaths :: [FilePath], - mainModIs :: Maybe String, + mainModIs :: Module, mainFunIs :: Maybe String, -- ways @@ -202,18 +211,22 @@ data DynFlags = DynFlags { rtsBuildTag :: String, -- the RTS "way" -- paths etc. - outputDir :: Maybe String, - outputFile :: Maybe String, - outputHi :: Maybe String, + objectDir :: Maybe String, + hiDir :: Maybe String, + stubDir :: Maybe String, + objectSuf :: String, hcSuf :: String, - hiDir :: Maybe String, hiSuf :: String, + + outputFile :: Maybe String, + outputHi :: Maybe String, + includePaths :: [String], libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto - tmpDir :: String, + tmpDir :: String, -- no trailing '/' -- options for particular phases opt_L :: [String], @@ -237,7 +250,7 @@ data DynFlags = DynFlags { pgm_l :: (String,[Option]), pgm_dll :: (String,[Option]), - -- ** Package flags + -- ** Package flags extraPkgConfs :: [FilePath], -- The -package-conf flags given on the command line, in the order -- they appeared. @@ -245,11 +258,14 @@ data DynFlags = DynFlags { packageFlags :: [PackageFlag], -- The -package and -hide-package flags from the command-line - -- ** Package state + -- ** Package state pkgState :: PackageState, -- hsc dynamic flags - flags :: [DynFlag] + flags :: [DynFlag], + + -- message output + log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO () } data HscTarget @@ -290,9 +306,7 @@ data PackageFlag | IgnorePackage String defaultHscTarget -#if defined(i386_TARGET_ARCH) || defined(sparc_TARGET_ARCH) || defined(powerpc_TARGET_ARCH) | cGhcWithNativeCodeGen == "YES" = HscAsm -#endif | otherwise = HscC initDynFlags dflags = do @@ -314,8 +328,6 @@ defaultDynFlags = stgToDo = Nothing, hscTarget = defaultHscTarget, hscOutName = "", - hscStubHOutName = "", - hscStubCOutName = "", extCoreName = "", verbosity = 0, optLevel = 0, @@ -324,25 +336,28 @@ defaultDynFlags = stolen_x86_regs = 4, cmdlineHcIncludes = [], importPaths = ["."], - mainModIs = Nothing, + mainModIs = mAIN, mainFunIs = Nothing, wayNames = panic "ways", buildTag = panic "buildTag", rtsBuildTag = panic "rtsBuildTag", - outputDir = Nothing, - outputFile = Nothing, - outputHi = Nothing, + objectDir = Nothing, + hiDir = Nothing, + stubDir = Nothing, + objectSuf = phaseInputExt StopLn, hcSuf = phaseInputExt HCc, - hiDir = Nothing, hiSuf = "hi", + + outputFile = Nothing, + outputHi = Nothing, includePaths = [], libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], - tmpDir = [], + tmpDir = cDEFAULT_TMPDIR, opt_L = [], opt_P = [], @@ -392,7 +407,13 @@ defaultDynFlags = Opt_IgnoreInterfacePragmas, Opt_OmitInterfacePragmas - ] ++ standardWarnings + ] ++ standardWarnings, + + log_action = \severity srcSpan style msg -> + case severity of + SevInfo -> hPutStrLn stderr (show (msg style)) + SevFatal -> hPutStrLn stderr (show (msg style)) + _ -> hPutStrLn stderr ('\n':show ((mkLocMessage srcSpan msg) style)) } {- @@ -424,14 +445,16 @@ getVerbFlag dflags | verbosity dflags >= 3 = "-v" | otherwise = "" -setOutputDir f d = d{ outputDir = f} -setOutputFile f d = d{ outputFile = f} -setOutputHi f d = d{ outputHi = f} +setObjectDir f d = d{ objectDir = f} +setHiDir f d = d{ hiDir = f} +setStubDir f d = d{ stubDir = f} + 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} +setHcSuf f d = d{ hcSuf = f} + +setOutputFile f d = d{ outputFile = f} +setOutputHi f d = d{ outputHi = f} -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. @@ -600,7 +623,6 @@ getCoreToDo dflags MaxSimplifierIterations max_iter ] ] - else {- opt_level >= 1 -} [ -- initial simplify: mk specialiser happy: minimum effort please @@ -769,6 +791,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. @@ -785,7 +811,7 @@ dynamic_flags = [ , ( "framework" , HasArg (upd . addCmdlineFramework) ) ------- Output Redirection ------------------------------------------ - , ( "odir" , HasArg (upd . setOutputDir . Just)) + , ( "odir" , HasArg (upd . setObjectDir . Just)) , ( "o" , SepArg (upd . setOutputFile . Just)) , ( "ohi" , HasArg (upd . setOutputHi . Just )) , ( "osuf" , HasArg (upd . setObjectSuf)) @@ -793,6 +819,7 @@ dynamic_flags = [ , ( "hisuf" , HasArg (upd . setHiSuf)) , ( "hidir" , HasArg (upd . setHiDir . Just)) , ( "tmpdir" , HasArg (upd . setTmpDir)) + , ( "stubdir" , HasArg (upd . setStubDir . Just)) ------- Keeping temporary files ------------------------------------- , ( "keep-hc-file" , AnySuffix (\_ -> setDynFlag Opt_KeepHcFiles)) @@ -814,6 +841,7 @@ dynamic_flags = [ , ( "package-name" , HasArg ignorePackage ) -- for compatibility , ( "package" , HasArg exposePackage ) , ( "hide-package" , HasArg hidePackage ) + , ( "hide-all-packages", NoArg (setDynFlag Opt_HideAllPackages) ) , ( "ignore-package" , HasArg ignorePackage ) , ( "syslib" , HasArg exposePackage ) -- for compatibility @@ -861,7 +889,7 @@ dynamic_flags = [ , ( "dsource-stats", setDumpFlag Opt_D_source_stats) , ( "dverbose-core2core", setDumpFlag Opt_D_verbose_core2core) , ( "dverbose-stg2stg", setDumpFlag Opt_D_verbose_stg2stg) - , ( "ddump-hi-diffs", setDumpFlag Opt_D_dump_hi_diffs) + , ( "ddump-hi-diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs)) , ( "ddump-hi", setDumpFlag Opt_D_dump_hi) , ( "ddump-minimal-imports", setDumpFlag Opt_D_dump_minimal_imports) , ( "ddump-vect", setDumpFlag Opt_D_dump_vect) @@ -900,6 +928,7 @@ dynamic_flags = [ ------ Compiler flags ----------------------------------------------- + , ( "fno-code", NoArg (setTarget HscNothing)) , ( "fasm", AnySuffix (\_ -> setTarget HscAsm) ) , ( "fvia-c", NoArg (setTarget HscC) ) , ( "fvia-C", NoArg (setTarget HscC) ) @@ -1034,18 +1063,17 @@ setOptLevel n dflags setMainIs :: String -> DynP () setMainIs arg - | not (null main_mod) -- The arg looked like "Foo.baz" + | not (null main_fn) -- The arg looked like "Foo.baz" = upd $ \d -> d{ mainFunIs = Just main_fn, - mainModIs = Just main_mod } + mainModIs = mkModule main_mod } - | isUpper (head main_fn) -- The arg looked like "Foo" - = upd $ \d -> d{ mainModIs = Just main_fn } + | isUpper (head main_mod) -- The arg looked like "Foo" + = upd $ \d -> d{ mainModIs = mkModule main_mod } | otherwise -- The arg looked like "baz" - = upd $ \d -> d{ mainFunIs = Just main_fn } + = upd $ \d -> d{ mainFunIs = Just main_mod } where (main_mod, main_fn) = splitLongestPrefix arg (== '.') - ----------------------------------------------------------------------------- -- Paths & Libraries @@ -1088,20 +1116,20 @@ splitPathList s = filter notNull (splitUp s) -- that this will cause too much breakage for users & ':' will -- work fine even with DOS paths, if you're not insisting on being silly. -- So, use either. - splitUp [] = [] - splitUp (x:':':div:xs) - | div `elem` dir_markers = do - let (p,rs) = findNextPath xs - in ((x:':':div:p): splitUp rs) + splitUp [] = [] + splitUp (x:':':div:xs) | div `elem` dir_markers + = ((x:':':div:p): splitUp rs) + where + (p,rs) = findNextPath xs -- we used to check for existence of the path here, but that -- required the IO monad to be threaded through the command-line -- parser which is quite inconvenient. The - splitUp xs = do - let (p,rs) = findNextPath xs - return (cons p (splitUp rs)) + splitUp xs = cons p (splitUp rs) + where + (p,rs) = findNextPath xs - cons "" xs = xs - cons x xs = x:xs + cons "" xs = xs + cons x xs = x:xs -- will be called either when we've consumed nought or the -- ":/" part of a DOS path, so splitting is just a Q of @@ -1118,6 +1146,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 @@ -1183,7 +1245,13 @@ machdepCCOpts dflags = ( [], ["-fomit-frame-pointer", "-G0"] ) #elif x86_64_TARGET_ARCH - = ( [], ["-fomit-frame-pointer"] ) + = ( [], ["-fomit-frame-pointer", + "-fno-asynchronous-unwind-tables" + -- the unwind tables are unnecessary for HC code, + -- and get in the way of -split-objs. Another option + -- would be to throw them away in the mangler, but this + -- is easier. + ] ) #elif mips_TARGET_ARCH = ( ["-static"], [] ) @@ -1228,3 +1296,23 @@ picCCOpts dflags | otherwise = [] #endif + +-- ----------------------------------------------------------------------------- +-- Splitting + +can_split :: Bool +can_split = +#if defined(i386_TARGET_ARCH) \ + || defined(x86_64_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 +