diff options
author | Ian Lynagh <ian@well-typed.com> | 2012-09-03 17:02:18 +0100 |
---|---|---|
committer | Ian Lynagh <ian@well-typed.com> | 2012-09-03 17:02:18 +0100 |
commit | 46258b406fcc17c4ba50d512894989f4c387ea33 (patch) | |
tree | 6b7fa024ccd0deb6fbf282e16d218ee1ee0bbdb4 /compiler | |
parent | 494eb3dc2bdbe76170044631b98884c56e9acfd3 (diff) | |
download | haskell-46258b406fcc17c4ba50d512894989f4c387ea33.tar.gz |
Make the ways dynamic
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/cmm/CLabel.hs | 11 | ||||
-rw-r--r-- | compiler/main/DriverPipeline.hs | 14 | ||||
-rw-r--r-- | compiler/main/DynFlags.hs | 252 | ||||
-rw-r--r-- | compiler/main/Packages.lhs | 9 | ||||
-rw-r--r-- | compiler/main/StaticFlagParser.hs | 44 | ||||
-rw-r--r-- | compiler/main/StaticFlags.hs | 220 | ||||
-rw-r--r-- | compiler/main/TidyPgm.lhs | 25 | ||||
-rw-r--r-- | compiler/nativeGen/PIC.hs | 15 | ||||
-rw-r--r-- | compiler/simplCore/CoreMonad.lhs | 2 | ||||
-rw-r--r-- | compiler/stgSyn/StgSyn.lhs | 4 |
10 files changed, 278 insertions, 318 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 6ffbbc774d..ed4b56767a 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -104,7 +104,6 @@ module CLabel ( ) where import IdInfo -import StaticFlags import BasicTypes import Packages import DataCon @@ -808,15 +807,15 @@ labelDynamic :: DynFlags -> PackageId -> CLabel -> Bool labelDynamic dflags this_pkg lbl = case lbl of -- is the RTS in a DLL or not? - RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) + RtsLabel _ -> not (dopt Opt_Static dflags) && (this_pkg /= rtsPackageId) - IdLabel n _ _ -> isDllName this_pkg n + IdLabel n _ _ -> isDllName dflags this_pkg n -- When compiling in the "dyn" way, each package is to be linked into -- its own shared library. CmmLabel pkg _ _ | os == OSMinGW32 -> - not opt_Static && (this_pkg /= pkg) + not (dopt Opt_Static dflags) && (this_pkg /= pkg) | otherwise -> True @@ -834,14 +833,14 @@ labelDynamic dflags this_pkg lbl = -- When compiling in the "dyn" way, each package is to be -- linked into its own DLL. ForeignLabelInPackage pkgId -> - (not opt_Static) && (this_pkg /= pkgId) + (not (dopt Opt_Static dflags)) && (this_pkg /= pkgId) else -- On Mac OS X and on ELF platforms, false positives are OK, -- so we claim that all foreign imports come from dynamic -- libraries True - PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) + PlainModuleInitLabel m -> not (dopt Opt_Static dflags) && this_pkg /= (modulePackageId m) -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 6eff097bfb..a579519ae6 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -39,7 +39,7 @@ import Module import UniqFM ( eltsUFM ) import ErrUtils import DynFlags -import StaticFlags ( v_Ld_inputs, opt_Static, Way(..) ) +import StaticFlags ( v_Ld_inputs ) import Config import Panic import Util @@ -1352,9 +1352,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,7 +1448,7 @@ maybeMergeStub runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool runPhase_MoveBinary dflags input_fn - | WayPar `elem` ways 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` ways dflags = do let sysMan = pgm_sysman dflags @@ -1668,7 +1668,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] @@ -1891,7 +1891,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] diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index b227172264..8a87188452 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -50,6 +50,8 @@ module DynFlags ( printOutputForUser, printInfoForUser, + Way(..), mkBuildTag, wayRTSOnly, + -- ** Safe Haskell SafeHaskellMode(..), safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, @@ -122,7 +124,6 @@ import Platform import Module import PackageConfig import PrelNames ( mAIN ) -import StaticFlags import {-# SOURCE #-} Packages (PackageState) import DriverPhases ( Phase(..), phaseInputExt ) import Config @@ -144,7 +145,7 @@ import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) import System.IO.Unsafe ( unsafePerformIO ) #endif import Data.IORef -import Control.Monad ( when ) +import Control.Monad import Data.Char import Data.List @@ -325,6 +326,8 @@ data DynFlag | Opt_GranMacros | Opt_PIC | Opt_SccProfilingOn + | Opt_Ticky + | Opt_Static -- output style opts | Opt_PprCaseAsLet @@ -852,12 +855,8 @@ 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. +doingTickyProfiling dflags = dopt Opt_Ticky dflags data PackageFlag = ExposePackage String @@ -899,19 +898,184 @@ 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 :: Way -> DynP () +wayOpts WayThreaded = do +#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: + upd $ addOptl "-lthr" +#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS) + upd $ addOptc "-pthread" + upd $ addOptl "-pthread" +#elif defined(solaris2_TARGET_OS) + upd $ addOptl "-lrt" +#endif + return () +wayOpts WayDebug = return () +wayOpts WayDyn = do + upd $ addOptP "-DDYNAMIC" + upd $ addOptc "-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. + setFPIC +#elif defined(darwin_TARGET_OS) + setFPIC +#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS) + -- Without this, linking the shared libHSffi fails because + -- it uses pthread mutexes. + upd $ addOptl "-optl-pthread" +#endif +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, @@ -980,7 +1144,7 @@ defaultDynFlags mySettings = packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", - ways = panic "defaultDynFlags: No ways", + ways = [], buildTag = panic "defaultDynFlags: No buildTag", rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", splitInfo = Nothing, @@ -1286,7 +1450,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 @@ -1332,6 +1496,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}) @@ -1483,7 +1648,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 @@ -1579,6 +1756,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,[])}))) @@ -1600,7 +1803,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) @@ -2064,9 +2267,6 @@ 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 ), @@ -2239,6 +2439,7 @@ xFlags = [ defaultFlags :: Platform -> [DynFlag] defaultFlags platform = [ Opt_AutoLinkPackages, + Opt_Static, Opt_SharedImplib, @@ -2260,7 +2461,6 @@ defaultFlags platform OSDarwin -> case platformArch platform of ArchX86_64 -> [Opt_PIC] - _ | not opt_Static -> [Opt_PIC] _ -> [] _ -> []) @@ -2524,6 +2724,11 @@ 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 }) + wayOpts w + +-------------------------- setDynFlag, unSetDynFlag :: DynFlag -> DynP () setDynFlag f = upd (\dfs -> dopt_set dfs f) unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) @@ -2667,7 +2872,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 @@ -2704,7 +2909,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 @@ -2879,7 +3084,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] diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 0f9ab3647b..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 @@ -896,7 +895,7 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) 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 8f6ff84ec8..05a463957e 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, Way(..) - , 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) @@ -131,12 +105,6 @@ flagsStatic = [ , 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 +134,6 @@ isStaticFlag f = "fno-pre-inlining", "fno-opt-coercion", "fexcess-precision", - "static", "fhardwire-lib-paths", "fcpr-off", "ferror-spans", @@ -203,9 +170,6 @@ type StaticP = EwM IO addOpt :: String -> StaticP () addOpt = liftEwM . SF.addOpt -addWay :: Way -> 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 ec5be5fa3b..34acd98b8a 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -23,9 +23,6 @@ module StaticFlags ( staticFlags, initStaticOpts, - -- Ways - Way(..), v_Ways, mkBuildTag, wayRTSOnly, - -- Output style options opt_PprStyle_Debug, opt_NoDebugOutput, @@ -66,18 +63,14 @@ module StaticFlags ( -- 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,7 +83,7 @@ import Util import Maybes ( firstJusts ) import Panic -import Control.Monad ( liftM3 ) +import Control.Monad import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Data.List @@ -104,9 +97,6 @@ initStaticOpts = writeIORef v_opt_C_ready True addOpt :: String -> IO () addOpt = consIORef v_opt_C -addWay :: Way -> IO () -addWay = consIORef v_Ways - removeOpt :: String -> IO () removeOpt f = do fs <- readIORef v_opt_C @@ -119,7 +109,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] @@ -129,10 +119,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 @@ -303,207 +289,16 @@ 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 Way - = WayThreaded - | WayDebug - | WayProf - | WayEventLog - | WayPar - | WayGran - | WayNDP - | WayDyn - deriving (Eq,Ord) - -GLOBAL_VAR(v_Ways, [] ,[Way]) - -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 - - -getWayFlags :: IO [String] -- new options -getWayFlags = do - unsorted <- readIORef v_Ways - let ways = sort $ nub $ unsorted - writeIORef v_Ways ways - - if not (allowed_combination 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)) - -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 :: Way -> [String] -wayOpts WayThreaded = [ -#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 - ] -wayOpts WayDebug = [] -wayOpts WayDyn = - [ "-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 - ] -wayOpts WayProf = - [ "-fscc-profiling" - , "-DPROFILING" - , "-optc-DPROFILING" ] -wayOpts WayEventLog = - [ "-DTRACING" - , "-optc-DTRACING" ] -wayOpts WayPar = - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-optc-DPAR" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-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 = - [ "-fgransim" - , "-D__GRANSIM__" - , "-optc-DGRAN" - , "-package concurrent" ] -wayOpts WayNDP = - [ "-XParr" - , "-fvectorise"] - ------------------------------------------------------------------------------ -- Tunneling our global variables into a new instance of the GHC library -- Ignore the v_Ld_inputs global because: @@ -512,12 +307,11 @@ wayOpts WayNDP = -- 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) +saveStaticFlagGlobals :: IO (Bool, [String]) +saveStaticFlagGlobals = liftM2 (,) (readIORef v_opt_C_ready) (readIORef v_opt_C) -restoreStaticFlagGlobals :: (Bool, [String], [Way]) -> IO () -restoreStaticFlagGlobals (c_ready, c, ways) = do +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/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 diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index fb75d87c77..0b5ffcd0d1 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -75,7 +75,6 @@ import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, import CLabel ( mkForeignLabel ) -import StaticFlags ( opt_Static ) import BasicTypes import Outputable @@ -161,7 +160,7 @@ cmmMakePicReference dflags lbl = CmmLit $ CmmLabel lbl - | (dopt Opt_PIC dflags || not opt_Static) && absoluteLabel lbl + | (dopt Opt_PIC dflags || not (dopt Opt_Static dflags)) && absoluteLabel lbl = CmmMachOp (MO_Add wordWidth) [ CmmReg (CmmGlobal PicBaseReg) , CmmLit $ picRelative @@ -214,14 +213,14 @@ howToAccessLabel -- To access the function at SYMBOL from our local module, we just need to -- dereference the local __imp_SYMBOL. -- --- If opt_Static is set then we assume that all our code will be linked +-- If Opt_Static is set then we assume that all our code will be linked -- into the same .exe file. In this case we always access symbols directly, -- and never use __imp_SYMBOL. -- howToAccessLabel dflags _ OSMinGW32 _ lbl -- Assume all symbols will be in the same PE, so just access them directly. - | opt_Static + | dopt Opt_Static dflags = AccessDirectly -- If the target symbol is in another PE we need to access it via the @@ -307,7 +306,7 @@ howToAccessLabel dflags _ os _ _ -- if we don't dynamically link to Haskell code, -- it actually manages to do so without messing thins up. | osElfTarget os - , not (dopt Opt_PIC dflags) && opt_Static + , not (dopt Opt_PIC dflags) && dopt Opt_Static dflags = AccessDirectly howToAccessLabel dflags arch os DataReference lbl @@ -429,12 +428,12 @@ needImportedSymbols dflags arch os -- PowerPC Linux: -fPIC or -dynamic | osElfTarget os , arch == ArchPPC - = dopt Opt_PIC dflags || not opt_Static + = dopt Opt_PIC dflags || not (dopt Opt_Static dflags) -- i386 (and others?): -dynamic but not -fPIC | osElfTarget os , arch /= ArchPPC_64 - = not opt_Static && not (dopt Opt_PIC dflags) + = not (dopt Opt_Static dflags) && not (dopt Opt_PIC dflags) | otherwise = False @@ -623,7 +622,7 @@ pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _ -- section. -- The "official" GOT mechanism (label@got) isn't intended to be used -- in position dependent code, so we have to create our own "fake GOT" --- when not Opt_PIC && not opt_Static. +-- when not Opt_PIC && not (dopt Opt_Static dflags). -- -- 2) PowerPC Linux is just plain broken. -- While it's theoretically possible to use GOT offsets larger diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index b1429c5dbf..5c97fbdbf3 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -720,7 +720,7 @@ data CoreReader = CoreReader { cr_hsc_env :: HscEnv, cr_rule_base :: RuleBase, cr_module :: Module, - cr_globals :: ((Bool, [String], [Way]), + cr_globals :: ((Bool, [String]), #ifdef GHCI (MVar PersistentLinkerState, Bool)) #else diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index 84a4c69af9..e5c525e4c3 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -106,14 +106,14 @@ data GenStgArg occ isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool isDllConApp dflags con args | platformOS (targetPlatform dflags) == OSMinGW32 - = isDllName this_pkg (dataConName con) || any is_dll_arg args + = isDllName dflags this_pkg (dataConName con) || any is_dll_arg args | otherwise = False where -- NB: typePrimRep is legit because any free variables won't have -- unlifted type (there are no unlifted things at top level) is_dll_arg :: StgArg -> Bool is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) - && isDllName this_pkg (idName v) + && isDllName dflags this_pkg (idName v) is_dll_arg _ = False this_pkg = thisPackage dflags |