diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/BreakArray.hs | 46 | ||||
| -rw-r--r-- | compiler/main/CodeOutput.lhs | 2 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 290 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 312 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 4 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 34 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 3 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 15 | ||||
| -rw-r--r-- | compiler/main/StaticFlagParser.hs | 47 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 249 | ||||
| -rw-r--r-- | compiler/main/SysTools.lhs | 11 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.lhs | 25 |
12 files changed, 507 insertions, 531 deletions
diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs index 91e4c96c9a..4d3145fb3a 100644 --- a/compiler/main/BreakArray.hs +++ b/compiler/main/BreakArray.hs @@ -25,62 +25,62 @@ module BreakArray #endif ) where +import DynFlags + #ifdef GHCI import Control.Monad import GHC.Exts import GHC.IO ( IO(..) ) -import Constants - data BreakArray = BA (MutableByteArray# RealWorld) breakOff, breakOn :: Word breakOn = 1 breakOff = 0 -showBreakArray :: BreakArray -> IO () -showBreakArray array = do - forM_ [0..(size array - 1)] $ \i -> do +showBreakArray :: DynFlags -> BreakArray -> IO () +showBreakArray dflags array = do + forM_ [0 .. (size dflags array - 1)] $ \i -> do val <- readBreakArray array i putStr $ ' ' : show val putStr "\n" -setBreakOn :: BreakArray -> Int -> IO Bool -setBreakOn array index - | safeIndex array index = do +setBreakOn :: DynFlags -> BreakArray -> Int -> IO Bool +setBreakOn dflags array index + | safeIndex dflags array index = do writeBreakArray array index breakOn return True | otherwise = return False -setBreakOff :: BreakArray -> Int -> IO Bool -setBreakOff array index - | safeIndex array index = do +setBreakOff :: DynFlags -> BreakArray -> Int -> IO Bool +setBreakOff dflags array index + | safeIndex dflags array index = do writeBreakArray array index breakOff return True | otherwise = return False -getBreak :: BreakArray -> Int -> IO (Maybe Word) -getBreak array index - | safeIndex array index = do +getBreak :: DynFlags -> BreakArray -> Int -> IO (Maybe Word) +getBreak dflags array index + | safeIndex dflags array index = do val <- readBreakArray array index return $ Just val | otherwise = return Nothing -safeIndex :: BreakArray -> Int -> Bool -safeIndex array index = index < size array && index >= 0 +safeIndex :: DynFlags -> BreakArray -> Int -> Bool +safeIndex dflags array index = index < size dflags array && index >= 0 -size :: BreakArray -> Int -size (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE +size :: DynFlags -> BreakArray -> Int +size dflags (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE dflags allocBA :: Int -> IO BreakArray allocBA (I# sz) = IO $ \s1 -> case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) } -- create a new break array and initialise elements to zero -newBreakArray :: Int -> IO BreakArray -newBreakArray entries@(I# sz) = do - BA array <- allocBA (entries * wORD_SIZE) +newBreakArray :: DynFlags -> Int -> IO BreakArray +newBreakArray dflags entries@(I# sz) = do + BA array <- allocBA (entries * wORD_SIZE dflags) case breakOff of W# off -> do -- Todo: there must be a better way to write zero as a Word! let loop n | n ==# sz = return () @@ -112,8 +112,8 @@ readBreakArray (BA array) (I# i) = readBA# array i -- presumably have a different representation. data BreakArray = Unspecified -newBreakArray :: Int -> IO BreakArray -newBreakArray _ = return Unspecified +newBreakArray :: DynFlags -> Int -> IO BreakArray +newBreakArray _ _ = return Unspecified #endif /* GHCI */ diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index e92eb4f34c..fc20ef4988 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -62,7 +62,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream do_lint cmm = do { showPass dflags "CmmLint" - ; case cmmLint (targetPlatform dflags) cmm of + ; case cmmLint dflags cmm of Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err ; ghcExit dflags 1 } diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index fe158460cb..0566d6ad65 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -39,7 +39,6 @@ import Module import UniqFM ( eltsUFM ) import ErrUtils import DynFlags -import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) ) import Config import Panic import Util @@ -357,7 +356,7 @@ linkingNeeded dflags linkables pkg_deps = do Left _ -> return True Right t -> do -- first check object files and extra_ld_inputs - extra_ld_inputs <- readIORef v_Ld_inputs + let extra_ld_inputs = ldInputs dflags e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs let (errs,extra_times) = splitEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times @@ -1352,9 +1351,9 @@ runPhase LlvmLlc input_fn dflags let lc_opts = getOpts dflags opt_lc opt_lvl = max 0 (min 2 $ optLevel dflags) - rmodel | dopt Opt_PIC dflags = "pic" - | not opt_Static = "dynamic-no-pic" - | otherwise = "static" + rmodel | dopt Opt_PIC dflags = "pic" + | not (dopt Opt_Static dflags) = "dynamic-no-pic" + | otherwise = "static" tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier | dopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" | otherwise = "--enable-tbaa=false" @@ -1448,9 +1447,9 @@ maybeMergeStub runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool runPhase_MoveBinary dflags input_fn - | WayPar `elem` (wayNames dflags) && not opt_Static = + | WayPar `elem` ways dflags && not (dopt Opt_Static dflags) = panic ("Don't know how to combine PVM wrapper and dynamic wrapper") - | WayPar `elem` (wayNames dflags) = do + | WayPar `elem` ways dflags = do let sysMan = pgm_sysman dflags pvm_root <- getEnv "PVM_ROOT" pvm_arch <- getEnv "PVM_ARCH" @@ -1557,7 +1556,7 @@ getLinkInfo dflags dep_packages = do pkg_frameworks <- case platformOS (targetPlatform dflags) of OSDarwin -> getPackageFrameworks dflags dep_packages _ -> return [] - extra_ld_inputs <- readIORef v_Ld_inputs + let extra_ld_inputs = ldInputs dflags let link_info = (package_link_opts, pkg_frameworks, @@ -1668,7 +1667,7 @@ linkBinary dflags o_files dep_packages = do get_pkg_lib_path_opts l | osElfTarget (platformOS platform) && dynLibLoader dflags == SystemDependent && - not opt_Static + not (dopt Opt_Static dflags) = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] | otherwise = ["-L" ++ l] @@ -1715,34 +1714,31 @@ linkBinary dflags o_files dep_packages = do return [] -- probably _stub.o files - extra_ld_inputs <- readIORef v_Ld_inputs + let extra_ld_inputs = ldInputs dflags -- opts from -optl-<blah> (including -l<blah> options) let extra_ld_opts = getOpts dflags opt_l - let ways = wayNames dflags - -- Here are some libs that need to be linked at the *end* of -- the command line, because they contain symbols that are referred to -- by the RTS. We can't therefore use the ordinary way opts for these. let - debug_opts | WayDebug `elem` ways = [ + debug_opts | WayDebug `elem` ways dflags = [ #if defined(HAVE_LIBBFD) "-lbfd", "-liberty" #endif ] | otherwise = [] - let - thread_opts | WayThreaded `elem` ways = [ -#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(netbsd_TARGET_OS) && !defined(haiku_TARGET_OS) - "-lpthread" -#endif -#if defined(osf3_TARGET_OS) - , "-lexc" -#endif - ] - | otherwise = [] + let thread_opts + | WayThreaded `elem` ways dflags = + let os = platformOS (targetPlatform dflags) + in if os == OSOsf3 then ["-lpthread", "-lexc"] + else if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD, + OSNetBSD, OSHaiku] + then [] + else ["-lpthread"] + | otherwise = [] rc_objs <- maybeCreateManifest dflags output_fn @@ -1893,7 +1889,7 @@ linkDynLib dflags o_files dep_packages get_pkg_lib_path_opts l | osElfTarget (platformOS (targetPlatform dflags)) && dynLibLoader dflags == SystemDependent && - not opt_Static + not (dopt Opt_Static dflags) = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] | otherwise = ["-L" ++ l] @@ -1907,7 +1903,9 @@ linkDynLib dflags o_files dep_packages -- not allow undefined symbols. -- The RTS library path is still added to the library search path -- above in case the RTS is being explicitly linked in (see #3807). - let pkgs_no_rts = case platformOS (targetPlatform dflags) of + let platform = targetPlatform dflags + os = platformOS platform + pkgs_no_rts = case os of OSMinGW32 -> pkgs _ -> @@ -1915,127 +1913,135 @@ linkDynLib dflags o_files dep_packages let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts -- probably _stub.o files - extra_ld_inputs <- readIORef v_Ld_inputs + let extra_ld_inputs = ldInputs dflags let extra_ld_opts = getOpts dflags opt_l -#if defined(mingw32_HOST_OS) - ----------------------------------------------------------------------------- - -- Making a DLL - ----------------------------------------------------------------------------- - let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } + case os of + OSMinGW32 -> do + ------------------------------------------------------------- + -- Making a DLL + ------------------------------------------------------------- + let output_fn = case o_file of + Just s -> s + Nothing -> "HSdll.dll" + + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + , SysTools.Option "-shared" + ] ++ + [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | dopt Opt_SharedImplib dflags + ] + ++ map (SysTools.FileOption "") o_files + ++ map SysTools.Option ( + + -- Permit the linker to auto link _symbol to _imp_symbol + -- This lets us link against DLLs without needing an "import library" + ["-Wl,--enable-auto-import"] + + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) + OSDarwin -> do + ------------------------------------------------------------------- + -- Making a darwin dylib + ------------------------------------------------------------------- + -- About the options used for Darwin: + -- -dynamiclib + -- Apple's way of saying -shared + -- -undefined dynamic_lookup: + -- Without these options, we'd have to specify the correct + -- dependencies for each of the dylibs. Note that we could + -- (and should) do without this for all libraries except + -- the RTS; all we need to do is to pass the correct + -- HSfoo_dyn.dylib files to the link command. + -- This feature requires Mac OS X 10.3 or later; there is + -- a similar feature, -flat_namespace -undefined suppress, + -- which works on earlier versions, but it has other + -- disadvantages. + -- -single_module + -- Build the dynamic library as a single "module", i.e. no + -- dynamic binding nonsense when referring to symbols from + -- within the library. The NCG assumes that this option is + -- specified (on i386, at least). + -- -install_name + -- Mac OS/X stores the path where a dynamic library is (to + -- be) installed in the library itself. It's called the + -- "install name" of the library. Then any library or + -- executable that links against it before it's installed + -- will search for it in its ultimate install location. + -- By default we set the install name to the absolute path + -- at build time, but it can be overridden by the + -- -dylib-install-name option passed to ghc. Cabal does + -- this. + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + instName <- case dylibInstallName dflags of + Just n -> return n + Nothing -> do + pwd <- getCurrentDirectory + return $ pwd `combine` output_fn + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-dynamiclib" + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + o_files + ++ [ "-undefined", "dynamic_lookup", "-single_module" ] + ++ (if platformArch platform == ArchX86_64 + then [ ] + else [ "-Wl,-read_only_relocs,suppress" ]) + ++ [ "-install_name", instName ] + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) + _ -> do + ------------------------------------------------------------------- + -- Making a DSO + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + let buildingRts = thisPackage dflags == rtsPackageId + let bsymbolicFlag = if buildingRts + then -- -Bsymbolic breaks the way we implement + -- hooks in the RTS + [] + else -- we need symbolic linking to resolve + -- non-PIC intra-package-relocations + ["-Wl,-Bsymbolic"] + + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + o_files + ++ [ "-shared" ] + ++ bsymbolicFlag + -- Set the library soname. We use -h rather than -soname as + -- Solaris 10 doesn't support the latter: + ++ [ "-Wl,-h," ++ takeFileName output_fn ] + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) - SysTools.runLink dflags ( - map SysTools.Option verbFlags - ++ [ SysTools.Option "-o" - , SysTools.FileOption "" output_fn - , SysTools.Option "-shared" - ] ++ - [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") - | dopt Opt_SharedImplib dflags - ] - ++ map (SysTools.FileOption "") o_files - ++ map SysTools.Option ( - - -- Permit the linker to auto link _symbol to _imp_symbol - -- This lets us link against DLLs without needing an "import library" - ["-Wl,--enable-auto-import"] - - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) -#elif defined(darwin_TARGET_OS) - ----------------------------------------------------------------------------- - -- Making a darwin dylib - ----------------------------------------------------------------------------- - -- About the options used for Darwin: - -- -dynamiclib - -- Apple's way of saying -shared - -- -undefined dynamic_lookup: - -- Without these options, we'd have to specify the correct dependencies - -- for each of the dylibs. Note that we could (and should) do without this - -- for all libraries except the RTS; all we need to do is to pass the - -- correct HSfoo_dyn.dylib files to the link command. - -- This feature requires Mac OS X 10.3 or later; there is a similar feature, - -- -flat_namespace -undefined suppress, which works on earlier versions, - -- but it has other disadvantages. - -- -single_module - -- Build the dynamic library as a single "module", i.e. no dynamic binding - -- nonsense when referring to symbols from within the library. The NCG - -- assumes that this option is specified (on i386, at least). - -- -install_name - -- Mac OS/X stores the path where a dynamic library is (to be) installed - -- in the library itself. It's called the "install name" of the library. - -- Then any library or executable that links against it before it's - -- installed will search for it in its ultimate install location. By - -- default we set the install name to the absolute path at build time, but - -- it can be overridden by the -dylib-install-name option passed to ghc. - -- Cabal does this. - ----------------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - - instName <- case dylibInstallName dflags of - Just n -> return n - Nothing -> do - pwd <- getCurrentDirectory - return $ pwd `combine` output_fn - SysTools.runLink dflags ( - map SysTools.Option verbFlags - ++ [ SysTools.Option "-dynamiclib" - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - o_files - ++ [ "-undefined", "dynamic_lookup", "-single_module", -#if !defined(x86_64_TARGET_ARCH) - "-Wl,-read_only_relocs,suppress", -#endif - "-install_name", instName ] - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) -#else - ----------------------------------------------------------------------------- - -- Making a DSO - ----------------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - let buildingRts = thisPackage dflags == rtsPackageId - let bsymbolicFlag = if buildingRts - then -- -Bsymbolic breaks the way we implement - -- hooks in the RTS - [] - else -- we need symbolic linking to resolve - -- non-PIC intra-package-relocations - ["-Wl,-Bsymbolic"] - - SysTools.runLink dflags ( - map SysTools.Option verbFlags - ++ [ SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - o_files - ++ [ "-shared" ] - ++ bsymbolicFlag - -- Set the library soname. We use -h rather than -soname as - -- Solaris 10 doesn't support the latter: - ++ [ "-Wl,-h," ++ takeFileName output_fn ] - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) -#endif -- ----------------------------------------------------------------------------- -- Running CPP diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 8abe664aa0..d4c3d535d6 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -20,6 +20,7 @@ module DynFlags ( WarningFlag(..), ExtensionFlag(..), Language(..), + PlatformConstants(..), FatalMessager, LogAction, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, @@ -45,11 +46,13 @@ module DynFlags ( Option(..), showOpt, DynLibLoader(..), fFlags, fWarningFlags, fLangFlags, xFlags, - wayNames, dynFlagDependencies, + dynFlagDependencies, tablesNextToCode, mkTablesNextToCode, printOutputForUser, printInfoForUser, + Way(..), mkBuildTag, wayRTSOnly, + -- ** Safe Haskell SafeHaskellMode(..), safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, @@ -82,7 +85,6 @@ module DynFlags ( updOptLevel, setTmpDir, setPackageName, - doingTickyProfiling, -- ** Parsing DynFlags parseDynamicFlagsCmdLine, @@ -114,6 +116,12 @@ module DynFlags ( #endif -- ** Only for use in the tracing functions in Outputable tracingDynFlags, + +#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellExports.hs" + bLOCK_SIZE_W, + wORD_SIZE_IN_BITS, + tAG_MASK, + mAX_PTR_TAG, ) where #include "HsVersions.h" @@ -122,12 +130,11 @@ import Platform import Module import PackageConfig import PrelNames ( mAIN ) -import StaticFlags import {-# SOURCE #-} Packages (PackageState) import DriverPhases ( Phase(..), phaseInputExt ) import Config import CmdLineParser -import Constants ( mAX_CONTEXT_REDUCTION_DEPTH ) +import Constants import Panic import Util import Maybes ( orElse ) @@ -144,8 +151,9 @@ import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) import System.IO.Unsafe ( unsafePerformIO ) #endif import Data.IORef -import Control.Monad ( when ) +import Control.Monad +import Data.Bits import Data.Char import Data.List import Data.Map (Map) @@ -325,6 +333,9 @@ data DynFlag | Opt_GranMacros | Opt_PIC | Opt_SccProfilingOn + | Opt_Ticky + | Opt_Static + | Opt_Hpc -- output style opts | Opt_PprCaseAsLet @@ -521,6 +532,7 @@ data DynFlags = DynFlags { liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches + historySize :: Int, cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], @@ -561,6 +573,8 @@ data DynFlags = DynFlags { -- Set by @-ddump-file-prefix@ dumpPrefixForce :: Maybe FilePath, + ldInputs :: [String], + includePaths :: [String], libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only @@ -699,8 +713,9 @@ data Settings = Settings { sOpt_l :: [String], sOpt_windres :: [String], sOpt_lo :: [String], -- LLVM: llvm optimiser - sOpt_lc :: [String] -- LLVM: llc static compiler + sOpt_lc :: [String], -- LLVM: llc static compiler + sPlatformConstants :: PlatformConstants } targetPlatform :: DynFlags -> Platform @@ -765,9 +780,6 @@ opt_lo dflags = sOpt_lo (settings dflags) opt_lc :: DynFlags -> [String] opt_lc dflags = sOpt_lc (settings dflags) -wayNames :: DynFlags -> [WayName] -wayNames = map wayName . ways - -- | The target code type of the compilation (if any). -- -- Whenever you change the target, also make sure to set 'ghcLink' to @@ -855,13 +867,6 @@ isNoLink :: GhcLink -> Bool isNoLink NoLink = True isNoLink _ = False --- Is it worth evaluating this Bool and caching it in the DynFlags value --- during initDynFlags? -doingTickyProfiling :: DynFlags -> Bool -doingTickyProfiling _ = opt_Ticky - -- XXX -ticky is a static flag, because it implies -debug which is also - -- static. If the way flags were made dynamic, we could fix this. - data PackageFlag = ExposePackage String | ExposePackageId String @@ -902,19 +907,187 @@ data DynLibLoader data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll deriving (Show) +----------------------------------------------------------------------------- +-- Ways + +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. + +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+threaded. + +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. + +data Way + = WayThreaded + | WayDebug + | WayProf + | WayEventLog + | WayPar + | WayGran + | WayNDP + | WayDyn + deriving (Eq,Ord) + +allowed_combination :: [Way] -> Bool +allowed_combination way = and [ x `allowedWith` y + | x <- way, y <- way, x < y ] + where + -- Note ordering in these tests: the left argument is + -- <= the right argument, according to the Ord instance + -- on Way above. + + -- dyn is allowed with everything + _ `allowedWith` WayDyn = True + WayDyn `allowedWith` _ = True + + -- debug is allowed with everything + _ `allowedWith` WayDebug = True + WayDebug `allowedWith` _ = True + + WayProf `allowedWith` WayNDP = True + WayThreaded `allowedWith` WayProf = True + WayThreaded `allowedWith` WayEventLog = True + _ `allowedWith` _ = False + +mkBuildTag :: [Way] -> String +mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) + +wayTag :: Way -> String +wayTag WayThreaded = "thr" +wayTag WayDebug = "debug" +wayTag WayDyn = "dyn" +wayTag WayProf = "p" +wayTag WayEventLog = "l" +wayTag WayPar = "mp" +-- wayTag WayPar = "mt" +-- wayTag WayPar = "md" +wayTag WayGran = "mg" +wayTag WayNDP = "ndp" + +wayRTSOnly :: Way -> Bool +wayRTSOnly WayThreaded = True +wayRTSOnly WayDebug = True +wayRTSOnly WayDyn = False +wayRTSOnly WayProf = False +wayRTSOnly WayEventLog = True +wayRTSOnly WayPar = False +-- wayRTSOnly WayPar = False +-- wayRTSOnly WayPar = False +wayRTSOnly WayGran = False +wayRTSOnly WayNDP = False + +wayDesc :: Way -> String +wayDesc WayThreaded = "Threaded" +wayDesc WayDebug = "Debug" +wayDesc WayDyn = "Dynamic" +wayDesc WayProf = "Profiling" +wayDesc WayEventLog = "RTS Event Logging" +wayDesc WayPar = "Parallel" +-- wayDesc WayPar = "Parallel ticky profiling" +-- wayDesc WayPar = "Distributed" +wayDesc WayGran = "GranSim" +wayDesc WayNDP = "Nested data parallelism" + +wayOpts :: Platform -> Way -> DynP () +wayOpts platform WayThreaded = do + -- FreeBSD's default threading library is the KSE-based M:N libpthread, + -- which GHC has some problems with. It's currently not clear whether + -- the problems are our fault or theirs, but it seems that using the + -- alternative 1:1 threading library libthr works around it: + let os = platformOS platform + case os of + OSFreeBSD -> upd $ addOptl "-lthr" + OSSolaris2 -> upd $ addOptl "-lrt" + _ + | os `elem` [OSOpenBSD, OSNetBSD] -> + do upd $ addOptc "-pthread" + upd $ addOptl "-pthread" + _ -> + return () +wayOpts _ WayDebug = return () +wayOpts platform WayDyn = do + upd $ addOptP "-DDYNAMIC" + upd $ addOptc "-DDYNAMIC" + let os = platformOS platform + case os of + OSMinGW32 -> + -- On Windows, code that is to be linked into a dynamic + -- library must be compiled with -fPIC. Labels not in + -- the current package are assumed to be in a DLL + -- different from the current one. + setFPIC + OSDarwin -> + setFPIC + _ | os `elem` [OSOpenBSD, OSNetBSD] -> + -- Without this, linking the shared libHSffi fails + -- because it uses pthread mutexes. + upd $ addOptl "-optl-pthread" + _ -> + return () +wayOpts _ WayProf = do + setDynFlag Opt_SccProfilingOn + upd $ addOptP "-DPROFILING" + upd $ addOptc "-DPROFILING" +wayOpts _ WayEventLog = do + upd $ addOptP "-DTRACING" + upd $ addOptc "-DTRACING" +wayOpts _ WayPar = do + setDynFlag Opt_Parallel + upd $ addOptP "-D__PARALLEL_HASKELL__" + upd $ addOptc "-DPAR" + exposePackage "concurrent" + upd $ addOptc "-w" + upd $ addOptl "-L${PVM_ROOT}/lib/${PVM_ARCH}" + upd $ addOptl "-lpvm3" + upd $ addOptl "-lgpvm3" +{- +wayOpts WayPar = + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-optc-DPAR" + , "-optc-DPAR_TICKY" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" ] +wayOpts WayPar = + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-D__DISTRIBUTED_HASKELL__" + , "-optc-DPAR" + , "-optc-DDIST" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" ] +-} +wayOpts _ WayGran = do + setDynFlag Opt_GranMacros + upd $ addOptP "-D__GRANSIM__" + upd $ addOptc "-DGRAN" + exposePackage "concurrent" +wayOpts _ WayNDP = do + setExtensionFlag Opt_ParallelArrays + setDynFlag Opt_Vectorise + +----------------------------------------------------------------------------- + -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do - -- someday these will be dynamic flags - ways <- readIORef v_Ways refFilesToClean <- newIORef [] refDirsToClean <- newIORef Map.empty refGeneratedDumps <- newIORef Set.empty refLlvmVersion <- newIORef 28 return dflags{ - ways = ways, - buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), - rtsBuildTag = mkBuildTag ways, filesToClean = refFilesToClean, dirsToClean = refDirsToClean, generatedDumps = refGeneratedDumps, @@ -942,6 +1115,7 @@ defaultDynFlags mySettings = specConstrCount = Just 3, liberateCaseThreshold = Just 2000, floatLamArgs = Just 0, -- Default: float only if no fvs + historySize = 20, strictnessBefore = [], cmdlineHcIncludes = [], @@ -970,6 +1144,7 @@ defaultDynFlags mySettings = dynLibLoader = SystemDependent, dumpPrefix = Nothing, dumpPrefixForce = Nothing, + ldInputs = [], includePaths = [], libraryPaths = [], frameworkPaths = [], @@ -983,9 +1158,9 @@ defaultDynFlags mySettings = packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", - ways = panic "defaultDynFlags: No ways", - buildTag = panic "defaultDynFlags: No buildTag", - rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", + ways = [], + buildTag = mkBuildTag [], + rtsBuildTag = mkBuildTag [], splitInfo = Nothing, settings = mySettings, -- ghc -M values @@ -1289,7 +1464,7 @@ getVerbFlags dflags setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, - setPgmP, addOptl, addOptP, + setPgmP, addOptl, addOptc, addOptP, addCmdlineFramework, addHaddockOpts, addGhciScript, setInteractivePrint :: String -> DynFlags -> DynFlags @@ -1335,6 +1510,7 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f} -- Config.hs should really use Option. setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) +addOptc f = alterSettings (\s -> s { sOpt_c = f : sOpt_c s}) addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) @@ -1420,7 +1596,7 @@ getStgToDo dflags todo1 = if stg_stats then [D_stg_stats] else [] - todo2 | WayProf `elem` wayNames dflags + todo2 | WayProf `elem` ways dflags = StgDoMassageForProfiling : todo1 | otherwise = todo1 @@ -1486,7 +1662,19 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do -- check for disabled flags in safe haskell let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 - return (dflags2, leftover, sh_warns ++ warns) + theWays = sort $ nub $ ways dflags2 + theBuildTag = mkBuildTag (filter (not . wayRTSOnly) theWays) + dflags3 = dflags2 { + ways = theWays, + buildTag = theBuildTag, + rtsBuildTag = mkBuildTag theWays + } + + unless (allowed_combination theWays) $ + ghcError (CmdLineError ("combination not supported: " ++ + intercalate "/" (map wayDesc theWays))) + + return (dflags3, leftover, sh_warns ++ warns) -- | Check (and potentially disable) any extensions that aren't allowed @@ -1582,6 +1770,32 @@ dynamic_flags = [ addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect")) , Flag "v" (OptIntSuffix setVerbosity) + ------- ways -------------------------------------------------------- + , Flag "prof" (NoArg (addWay WayProf)) + , Flag "eventlog" (NoArg (addWay WayEventLog)) + , Flag "parallel" (NoArg (addWay WayPar)) + , Flag "gransim" (NoArg (addWay WayGran)) + , Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) + , Flag "debug" (NoArg (addWay WayDebug)) + , Flag "ndp" (NoArg (addWay WayNDP)) + , Flag "threaded" (NoArg (addWay WayThreaded)) + + , Flag "ticky" (NoArg (setDynFlag Opt_Ticky >> addWay WayDebug)) + + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. + + ----- Linker -------------------------------------------------------- + -- -static is the default. If -dynamic has been given then, due to the + -- way wayOpts is currently used, we've already set -DDYNAMIC etc. + -- It's too fiddly to undo that, so we just give an error if + -- Opt_Static has been unset. + , Flag "static" (noArgM (\dfs -> do unless (dopt Opt_Static dfs) (addErr "Can't use -static after -dynamic") + return dfs)) + , Flag "dynamic" (NoArg (unSetDynFlag Opt_Static >> addWay WayDyn)) + -- ignored for compat w/ gcc: + , Flag "rdynamic" (NoArg (return ())) + ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) @@ -1603,7 +1817,7 @@ dynamic_flags = [ , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) , Flag "optP" (hasArg addOptP) , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) - , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , Flag "optc" (hasArg addOptc) , Flag "optm" (HasArg (\_ -> addWarn "The -optm flag does nothing; it will be removed in a future GHC release")) , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , Flag "optl" (hasArg addOptl) @@ -1839,6 +2053,7 @@ dynamic_flags = [ , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) + , Flag "fhistory-size" (intSuffix (\n d -> d{ historySize = n })) ------ Profiling ---------------------------------------------------- @@ -2067,13 +2282,11 @@ fFlags = [ ( "ghci-history", Opt_GhciHistory, nop ), ( "helpful-errors", Opt_HelpfulErrors, nop ), ( "defer-type-errors", Opt_DeferTypeErrors, nop ), - ( "parallel", Opt_Parallel, nop ), - ( "scc-profiling", Opt_SccProfilingOn, nop ), - ( "gransim", Opt_GranMacros, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ), ( "prof-count-entries", Opt_ProfCountEntries, nop ), - ( "prof-cafs", Opt_AutoSccsOnIndividualCafs, nop ) + ( "prof-cafs", Opt_AutoSccsOnIndividualCafs, nop ), + ( "hpc", Opt_Hpc, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ @@ -2242,12 +2455,11 @@ xFlags = [ defaultFlags :: Platform -> [DynFlag] defaultFlags platform = [ Opt_AutoLinkPackages, + Opt_Static, Opt_SharedImplib, -#if GHC_DEFAULT_NEW_CODEGEN Opt_TryNewCodeGen, -#endif Opt_GenManifest, Opt_EmbedManifest, @@ -2265,7 +2477,6 @@ defaultFlags platform OSDarwin -> case platformArch platform of ArchX86_64 -> [Opt_PIC] - _ | not opt_Static -> [Opt_PIC] _ -> [] _ -> []) @@ -2328,7 +2539,8 @@ optLevelFlags , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) - , ([2], Opt_RegsGraph) +-- XXX disabled, see #7192 +-- , ([2], Opt_RegsGraph) , ([0,1,2], Opt_LlvmTBAA) , ([0,1,2], Opt_RegLiveness) , ([1,2], Opt_CmmSink) @@ -2528,6 +2740,12 @@ setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags) setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) -------------------------- +addWay :: Way -> DynP () +addWay w = do upd (\dfs -> dfs { ways = w : ways dfs }) + dfs <- liftEwM getCmdLineState + wayOpts (targetPlatform dfs) w + +-------------------------- setDynFlag, unSetDynFlag :: DynFlag -> DynP () setDynFlag f = upd (\dfs -> dopt_set dfs f) unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) @@ -2671,7 +2889,7 @@ setObjTarget l = updM set return dflags HscLlvm | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) && - (not opt_Static || dopt Opt_PIC dflags) + (not (dopt Opt_Static dflags) || dopt Opt_PIC dflags) -> do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform") return dflags @@ -2708,7 +2926,7 @@ unSetFPIC = updM set | platformArch platform == ArchX86_64 -> do addWarn "Ignoring -fno-PIC on this platform" return dflags - _ | not opt_Static -> + _ | not (dopt Opt_Static dflags) -> do addWarn "Ignoring -fno-PIC as -fstatic is off" return dflags _ -> return $ dopt_unset dflags Opt_PIC @@ -2883,7 +3101,8 @@ picCCOpts dflags -- correctly. They need to reference data in the Haskell -- objects, but can't without -fPIC. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode - | dopt Opt_PIC dflags || not opt_Static -> ["-fPIC", "-U __PIC__", "-D__PIC__"] + | dopt Opt_PIC dflags || not (dopt Opt_Static dflags) -> + ["-fPIC", "-U __PIC__", "-D__PIC__"] | otherwise -> [] picPOpts :: DynFlags -> [String] @@ -2928,3 +3147,18 @@ compilerInfo dflags ("Global Package DB", systemPackageConfig dflags) ] +#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellType.hs" +#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellWrappers.hs" + +bLOCK_SIZE_W :: DynFlags -> Int +bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags + +wORD_SIZE_IN_BITS :: DynFlags -> Int +wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 + +tAG_MASK :: DynFlags -> Int +tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 + +mAX_PTR_TAG :: DynFlags -> Int +mAX_PTR_TAG = tAG_MASK + diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 22684126c2..6f9745dbfc 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1399,7 +1399,9 @@ tryNewCodeGen hsc_env this_mod data_tycons -- We are building a single SRT for the entire module, so -- we must thread it through all the procedures as we cps-convert them. us <- mkSplitUniqSupply 'S' - let initTopSRT = initUs_ us emptySRT + let srt_mod | dopt Opt_SplitObjs dflags = Just this_mod + | otherwise = Nothing + initTopSRT = initUs_ us (emptySRT srt_mod) let run_pipeline topSRT cmmgroup = do (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 793740e96e..7c1f169440 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -744,6 +744,22 @@ emptyModIface mod mi_trust = noIfaceTrustInfo, mi_trust_pkg = False } + +-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldr add_decl emptyOccEnv pairs + add_decl (v,d) env0 = foldr add env0 (ifaceDeclFingerprints v d) + where + add (occ,hash) env0 = extendOccEnv env0 occ (occ,hash) + +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing + + -- | The 'ModDetails' is essentially a cache for information in the 'ModIface' -- for home modules only. Information relating to packages will be loaded into -- global environments in 'ExternalPackageState'. @@ -1460,24 +1476,6 @@ class Monad m => MonadThings m where lookupTyCon = liftM tyThingTyCon . lookupThing \end{code} -\begin{code} --- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' -mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] - -> (OccName -> Maybe (OccName, Fingerprint)) -mkIfaceHashCache pairs - = \occ -> lookupOccEnv env occ - where - env = foldr add_decl emptyOccEnv pairs - add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclImplicitBndrs d) - where - decl_name = ifName d - env1 = extendOccEnv env0 decl_name (decl_name, v) - add_imp bndr env = extendOccEnv env bndr (decl_name, v) - -emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) -emptyIfaceHashCache _occ = Nothing -\end{code} - %************************************************************************ %* * \subsection{Auxiliary types} diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index a797329930..806f8356e6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -347,7 +347,8 @@ isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool isBreakEnabled hsc_env inf = case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of Just hmi -> do - w <- getBreak (modBreaks_flags (getModBreaks hmi)) + w <- getBreak (hsc_dflags hsc_env) + (modBreaks_flags (getModBreaks hmi)) (breakInfo_number inf) case w of Just n -> return (n /= 0); _other -> return False _ -> diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 5bea131088..87e573e628 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -37,7 +37,6 @@ where import PackageConfig import DynFlags -import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import UniqFM @@ -883,20 +882,20 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) where ways0 = ways dflags - ways1 = filter ((/= WayDyn) . wayName) ways0 + ways1 = filter (/= WayDyn) ways0 -- the name of a shared library is libHSfoo-ghc<version>.so -- we leave out the _dyn, because it is superfluous -- debug RTS includes support for -eventlog - ways2 | WayDebug `elem` map wayName ways1 - = filter ((/= WayEventLog) . wayName) ways1 + ways2 | WayDebug `elem` ways1 + = filter (/= WayEventLog) ways1 | otherwise = ways1 tag = mkBuildTag (filter (not . wayRTSOnly) ways2) rts_tag = mkBuildTag ways2 - mkDynName | opt_Static = id + mkDynName | dopt Opt_Static dflags = id | otherwise = (++ ("-ghc" ++ cProjectVersion)) addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) @@ -1031,12 +1030,12 @@ missingDependencyMsg (Just parent) -- ----------------------------------------------------------------------------- -- | Will the 'Name' come from a dynamically linked library? -isDllName :: PackageId -> Name -> Bool +isDllName :: DynFlags -> PackageId -> Name -> Bool -- Despite the "dll", I think this function just means that -- the synbol comes from another dynamically-linked package, -- and applies on all platforms, not just Windows -isDllName this_pkg name - | opt_Static = False +isDllName dflags this_pkg name + | dopt Opt_Static dflags = False | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg | otherwise = False -- no, it is not even an external name diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 2b7f95a910..36b32fa45f 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -18,8 +18,7 @@ module StaticFlagParser ( #include "HsVersions.h" import qualified StaticFlags as SF -import StaticFlags ( v_opt_C_ready, getWayFlags, WayName(..) - , opt_SimplExcessPrecision ) +import StaticFlags ( v_opt_C_ready, opt_SimplExcessPrecision ) import CmdLineParser import SrcLoc import Util @@ -60,18 +59,9 @@ parseStaticFlagsFull flagsAvailable args = do ready <- readIORef v_opt_C_ready when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession") - (leftover, errs, warns1) <- processArgs flagsAvailable args + (leftover, errs, warns) <- processArgs flagsAvailable args when (not (null errs)) $ ghcError $ errorsToGhcException errs - -- deal with the way flags: the way (eg. prof) gives rise to - -- further flags, some of which might be static. - way_flags <- getWayFlags - let way_flags' = map (mkGeneralLocated "in way flags") way_flags - - -- as these are GHC generated flags, we parse them with all static flags - -- in scope, regardless of what availableFlags are passed in. - (more_leftover, errs, warns2) <- processArgs flagsStatic way_flags' - -- see sanity code in staticOpts writeIORef v_opt_C_ready True @@ -83,9 +73,7 @@ parseStaticFlagsFull flagsAvailable args = do ["-fexcess-precision"] | otherwise = [] - when (not (null errs)) $ ghcError $ errorsToGhcException errs - return (excess_prec ++ more_leftover ++ leftover, - warns1 ++ warns2) + return (excess_prec ++ leftover, warns) flagsStatic :: [Flag IO] -- All the static flags should appear in this list. It describes how each @@ -102,22 +90,8 @@ flagsStatic :: [Flag IO] -- flags further down the list with the same prefix. flagsStatic = [ - ------- ways -------------------------------------------------------- - Flag "prof" (NoArg (addWay WayProf)) - , Flag "eventlog" (NoArg (addWay WayEventLog)) - , Flag "parallel" (NoArg (addWay WayPar)) - , Flag "gransim" (NoArg (addWay WayGran)) - , Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) - , Flag "debug" (NoArg (addWay WayDebug)) - , Flag "ndp" (NoArg (addWay WayNDP)) - , Flag "threaded" (NoArg (addWay WayThreaded)) - - , Flag "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug)) - -- -ticky enables ticky-ticky code generation, and also implies -debug which - -- is required to get the RTS ticky support. - ------ Debugging ---------------------------------------------------- - , Flag "dppr-debug" (PassFlag addOpt) + Flag "dppr-debug" (PassFlag addOpt) , Flag "dsuppress-all" (PassFlag addOpt) , Flag "dsuppress-uniques" (PassFlag addOpt) , Flag "dsuppress-coercions" (PassFlag addOpt) @@ -126,17 +100,9 @@ flagsStatic = [ , Flag "dsuppress-idinfo" (PassFlag addOpt) , Flag "dsuppress-var-kinds" (PassFlag addOpt) , Flag "dsuppress-type-signatures" (PassFlag addOpt) - , Flag "dopt-fuel" (AnySuffix addOpt) , Flag "dno-debug-output" (PassFlag addOpt) - , Flag "dstub-dead-values" (PassFlag addOpt) -- rest of the debugging flags are dynamic - ----- Linker -------------------------------------------------------- - , Flag "static" (PassFlag addOpt) - , Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) - -- ignored for compat w/ gcc: - , Flag "rdynamic" (NoArg (return ())) - ----- RTS opts ------------------------------------------------------ , Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s))))) @@ -166,7 +132,6 @@ isStaticFlag f = "fno-pre-inlining", "fno-opt-coercion", "fexcess-precision", - "static", "fhardwire-lib-paths", "fcpr-off", "ferror-spans", @@ -175,7 +140,6 @@ isStaticFlag f = || any (`isPrefixOf` f) [ "fliberate-case-threshold", "fmax-worker-args", - "fhistory-size", "funfolding-creation-threshold", "funfolding-dict-threshold", "funfolding-use-threshold", @@ -203,9 +167,6 @@ type StaticP = EwM IO addOpt :: String -> StaticP () addOpt = liftEwM . SF.addOpt -addWay :: WayName -> StaticP () -addWay = liftEwM . SF.addWay - removeOpt :: String -> StaticP () removeOpt = liftEwM . SF.removeOpt diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 2334940492..3165c6944b 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -23,9 +23,6 @@ module StaticFlags ( staticFlags, initStaticOpts, - -- Ways - WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag, - -- Output style options opt_PprStyle_Debug, opt_NoDebugOutput, @@ -40,9 +37,6 @@ module StaticFlags ( opt_SuppressTypeSignatures, opt_SuppressVarKinds, - -- Hpc opts - opt_Hpc, - -- language opts opt_DictsStrict, @@ -63,21 +57,11 @@ module StaticFlags ( opt_UF_KeenessFactor, opt_UF_DearOp, - -- Optimization fuel controls - opt_Fuel, - - -- Related to linking - opt_Static, - -- misc opts opt_ErrorSpans, - opt_HistorySize, - v_Ld_inputs, - opt_StubDeadValues, - opt_Ticky, -- For the parser - addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready, + addOpt, removeOpt, v_opt_C_ready, -- Saving/restoring globals saveStaticFlagGlobals, restoreStaticFlagGlobals @@ -90,9 +74,7 @@ import Util import Maybes ( firstJusts ) import Panic -import Control.Monad ( liftM3 ) -import Data.Function -import Data.Maybe ( listToMaybe ) +import Control.Monad import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Data.List @@ -106,9 +88,6 @@ initStaticOpts = writeIORef v_opt_C_ready True addOpt :: String -> IO () addOpt = consIORef v_opt_C -addWay :: WayName -> IO () -addWay = consIORef v_Ways . lkupWay - removeOpt :: String -> IO () removeOpt f = do fs <- readIORef v_opt_C @@ -121,7 +100,7 @@ lookup_str :: String -> Maybe String -- holds the static opts while they're being collected, before -- being unsafely read by unpacked_static_opts below. -GLOBAL_VAR(v_opt_C, defaultStaticOpts, [String]) +GLOBAL_VAR(v_opt_C, [], [String]) GLOBAL_VAR(v_opt_C_ready, False, Bool) staticFlags :: [String] @@ -131,10 +110,6 @@ staticFlags = unsafePerformIO $ do then panic "Static flags have not been initialised!\n Please call GHC.newSession or GHC.parseStaticFlags early enough." else readIORef v_opt_C --- -static is the default -defaultStaticOpts :: [String] -defaultStaticOpts = ["-static"] - packed_static_opts :: [FastString] packed_static_opts = map mkFastString staticFlags @@ -238,16 +213,9 @@ opt_SuppressUniques opt_PprStyle_Debug :: Bool opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") -opt_Fuel :: Int -opt_Fuel = lookup_def_int "-dopt-fuel" maxBound - opt_NoDebugOutput :: Bool opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") --- Hpc opts -opt_Hpc :: Bool -opt_Hpc = lookUp (fsLit "-fhpc") - -- language opts opt_DictsStrict :: Bool opt_DictsStrict = lookUp (fsLit "-fdicts-strict") @@ -264,12 +232,6 @@ opt_CprOff = lookUp (fsLit "-fcpr-off") opt_MaxWorkerArgs :: Int opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) -opt_HistorySize :: Int -opt_HistorySize = lookup_def_int "-fhistory-size" 20 - -opt_StubDeadValues :: Bool -opt_StubDeadValues = lookUp (fsLit "-dstub-dead-values") - -- Simplifier switches opt_SimplNoPreInlining :: Bool opt_SimplNoPreInlining = lookUp (fsLit "-fno-pre-inlining") @@ -305,213 +267,18 @@ opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Fl opt_UF_DearOp = ( 40 :: Int) --- Related to linking -opt_Static :: Bool -opt_Static = lookUp (fsLit "-static") - -- Include full span info in error messages, instead of just the start position. opt_ErrorSpans :: Bool opt_ErrorSpans = lookUp (fsLit "-ferror-spans") -opt_Ticky :: Bool -opt_Ticky = lookUp (fsLit "-ticky") - --- object files and libraries to be linked in are collected here. --- ToDo: perhaps this could be done without a global, it wasn't obvious --- how to do it though --SDM. -GLOBAL_VAR(v_Ld_inputs, [], [String]) - ------------------------------------------------------------------------------ --- Ways - --- The central concept of a "way" is that all objects in a given --- program must be compiled in the same "way". Certain options change --- parameters of the virtual machine, eg. profiling adds an extra word --- to the object header, so profiling objects cannot be linked with --- non-profiling objects. - --- After parsing the command-line options, we determine which "way" we --- are building - this might be a combination way, eg. profiling+threaded. - --- We then find the "build-tag" associated with this way, and this --- becomes the suffix used to find .hi files and libraries used in --- this compilation. - -data WayName - = WayThreaded - | WayDebug - | WayProf - | WayEventLog - | WayPar - | WayGran - | WayNDP - | WayDyn - deriving (Eq,Ord) - -GLOBAL_VAR(v_Ways, [] ,[Way]) - -allowed_combination :: [WayName] -> Bool -allowed_combination way = and [ x `allowedWith` y - | x <- way, y <- way, x < y ] - where - -- Note ordering in these tests: the left argument is - -- <= the right argument, according to the Ord instance - -- on Way above. - - -- dyn is allowed with everything - _ `allowedWith` WayDyn = True - WayDyn `allowedWith` _ = True - - -- debug is allowed with everything - _ `allowedWith` WayDebug = True - WayDebug `allowedWith` _ = True - - WayProf `allowedWith` WayNDP = True - WayThreaded `allowedWith` WayProf = True - WayThreaded `allowedWith` WayEventLog = True - _ `allowedWith` _ = False - - -getWayFlags :: IO [String] -- new options -getWayFlags = do - unsorted <- readIORef v_Ways - let ways = sortBy (compare `on` wayName) $ - nubBy ((==) `on` wayName) $ unsorted - writeIORef v_Ways ways - - if not (allowed_combination (map wayName ways)) - then ghcError (CmdLineError $ - "combination not supported: " ++ - foldr1 (\a b -> a ++ '/':b) - (map wayDesc ways)) - else - return (concatMap wayOpts ways) - -mkBuildTag :: [Way] -> String -mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) - -lkupWay :: WayName -> Way -lkupWay w = - case listToMaybe (filter ((==) w . wayName) way_details) of - Nothing -> error "findBuildTag" - Just details -> details - -isRTSWay :: WayName -> Bool -isRTSWay = wayRTSOnly . lkupWay - -data Way = Way { - wayName :: WayName, - wayTag :: String, - wayRTSOnly :: Bool, - wayDesc :: String, - wayOpts :: [String] - } - -way_details :: [ Way ] -way_details = - [ Way WayThreaded "thr" True "Threaded" [ -#if defined(freebsd_TARGET_OS) --- "-optc-pthread" --- , "-optl-pthread" - -- FreeBSD's default threading library is the KSE-based M:N libpthread, - -- which GHC has some problems with. It's currently not clear whether - -- the problems are our fault or theirs, but it seems that using the - -- alternative 1:1 threading library libthr works around it: - "-optl-lthr" -#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS) - "-optc-pthread" - , "-optl-pthread" -#elif defined(solaris2_TARGET_OS) - "-optl-lrt" -#endif - ], - - Way WayDebug "debug" True "Debug" [], - - Way WayDyn "dyn" False "Dynamic" - [ "-DDYNAMIC" - , "-optc-DDYNAMIC" -#if defined(mingw32_TARGET_OS) - -- On Windows, code that is to be linked into a dynamic library must be compiled - -- with -fPIC. Labels not in the current package are assumed to be in a DLL - -- different from the current one. - , "-fPIC" -#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS) - -- Without this, linking the shared libHSffi fails because - -- it uses pthread mutexes. - , "-optl-pthread" -#endif - ], - - Way WayProf "p" False "Profiling" - [ "-fscc-profiling" - , "-DPROFILING" - , "-optc-DPROFILING" ], - - Way WayEventLog "l" True "RTS Event Logging" - [ "-DTRACING" - , "-optc-DTRACING" ], - - Way WayPar "mp" False "Parallel" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-optc-DPAR" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-lgpvm3" ], - - -- at the moment we only change the RTS and could share compiler and libs! - Way WayPar "mt" False "Parallel ticky profiling" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-optc-DPAR" - , "-optc-DPAR_TICKY" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-lgpvm3" ], - - Way WayPar "md" False "Distributed" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-D__DISTRIBUTED_HASKELL__" - , "-optc-DPAR" - , "-optc-DDIST" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-lgpvm3" ], - - Way WayGran "mg" False "GranSim" - [ "-fgransim" - , "-D__GRANSIM__" - , "-optc-DGRAN" - , "-package concurrent" ], - - Way WayNDP "ndp" False "Nested data parallelism" - [ "-XParr" - , "-fvectorise"] - ] - ----------------------------------------------------------------------------- -- Tunneling our global variables into a new instance of the GHC library --- Ignore the v_Ld_inputs global because: --- a) It is mutated even once GHC has been initialised, which means that I'd --- have to add another layer of indirection to truly share the value --- b) We can get away without sharing it because it only affects the link, --- and is mutated by the GHC exe. Users who load up a new copy of the GHC --- library while another is running almost certainly won't actually access it. -saveStaticFlagGlobals :: IO (Bool, [String], [Way]) -saveStaticFlagGlobals = liftM3 (,,) (readIORef v_opt_C_ready) (readIORef v_opt_C) (readIORef v_Ways) - -restoreStaticFlagGlobals :: (Bool, [String], [Way]) -> IO () -restoreStaticFlagGlobals (c_ready, c, ways) = do +saveStaticFlagGlobals :: IO (Bool, [String]) +saveStaticFlagGlobals = liftM2 (,) (readIORef v_opt_C_ready) (readIORef v_opt_C) + +restoreStaticFlagGlobals :: (Bool, [String]) -> IO () +restoreStaticFlagGlobals (c_ready, c) = do writeIORef v_opt_C_ready c_ready writeIORef v_opt_C c - writeIORef v_Ways ways diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 7d905d35c6..2154cd3235 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -172,15 +172,23 @@ initSysTools mbMinusB -- format, '/' separated let settingsFile = top_dir </> "settings" + platformConstantsFile = top_dir </> "platformConstants" installed :: FilePath -> FilePath installed file = top_dir </> file settingsStr <- readFile settingsFile + platformConstantsStr <- readFile platformConstantsFile mySettings <- case maybeReadFuzzy settingsStr of Just s -> return s Nothing -> pgmError ("Can't parse " ++ show settingsFile) + platformConstants <- case maybeReadFuzzy platformConstantsStr of + Just s -> + return s + Nothing -> + pgmError ("Can't parse " ++ + show platformConstantsFile) let getSetting key = case lookup key mySettings of Just xs -> return $ case stripPrefix "$topdir" xs of @@ -326,7 +334,8 @@ initSysTools mbMinusB sOpt_l = [], sOpt_windres = [], sOpt_lo = [], - sOpt_lc = [] + sOpt_lc = [], + sPlatformConstants = platformConstants } \end{code} diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index bea9f14ee6..ffd5de809d 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -47,7 +47,6 @@ import Module import Packages( isDllName ) import HscTypes import Maybes -import Platform import UniqSupply import ErrUtils (Severity(..)) import Outputable @@ -1049,20 +1048,20 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) return $ tidy mkIntegerId init_env binds where - platform = targetPlatform (hsc_dflags hsc_env) + dflags = hsc_dflags hsc_env init_env = (init_occ_env, emptyVarEnv) - this_pkg = thisPackage (hsc_dflags hsc_env) + this_pkg = thisPackage dflags tidy _ env [] = (env, []) - tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind platform this_pkg mkIntegerId unfold_env env b + tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind dflags this_pkg mkIntegerId unfold_env env b (env2, bs') = tidy mkIntegerId env1 bs in (env2, b':bs') ------------------------ -tidyTopBind :: Platform +tidyTopBind :: DynFlags -> PackageId -> Id -> UnfoldEnv @@ -1070,16 +1069,16 @@ tidyTopBind :: Platform -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) +tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs + caf_info = hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) +tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) = (tidy_env2, Rec prs') where prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs) @@ -1096,7 +1095,7 @@ tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info - | or [ mayHaveCafRefs (hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -1233,15 +1232,15 @@ it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: Platform -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr +hasCafRefs :: DynFlags -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo -hasCafRefs platform this_pkg p arity expr +hasCafRefs dflags this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefsE p expr) - is_dynamic_name = isDllName this_pkg - is_caf = not (arity > 0 || rhsIsStatic platform is_dynamic_name expr) + is_dynamic_name = isDllName dflags this_pkg + is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity |