diff options
| -rw-r--r-- | compiler/GHC.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/CoreToStg.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/CoreToStg/Prep.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Driver/MakeFile.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Packages.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 31 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Ways.hs | 19 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Usage.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Runtime/Linker.hs | 7 | ||||
| -rw-r--r-- | compiler/main/SysTools.hs | 4 | ||||
| -rw-r--r-- | ghc/Main.hs | 5 | ||||
| -rw-r--r-- | ghc/ghc-bin.cabal.in | 2 |
12 files changed, 61 insertions, 52 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 256a414e64..11c1ce8521 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -336,6 +336,7 @@ import GHC.Driver.Finder import GHC.Driver.Types import GHC.Driver.CmdLine import GHC.Driver.Session hiding (WarnReason(..)) +import GHC.Driver.Ways import SysTools import SysTools.BaseDir import Annotations @@ -365,6 +366,7 @@ import FileCleanup import Data.Foldable import qualified Data.Map.Strict as Map import Data.Set (Set) +import qualified Data.Set as S import qualified Data.Sequence as Seq import Data.Maybe import Data.Time @@ -542,10 +544,10 @@ checkBrokenTablesNextToCode dflags checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool checkBrokenTablesNextToCode' dflags - | not (isARM arch) = return False - | WayDyn `notElem` ways dflags = return False - | not (tablesNextToCode dflags) = return False - | otherwise = do + | not (isARM arch) = return False + | WayDyn `S.notMember` ways dflags = return False + | not (tablesNextToCode dflags) = return False + | otherwise = do linkerInfo <- liftIO $ getLinkerInfo dflags case linkerInfo of GnuLD _ -> return True @@ -605,9 +607,9 @@ setSessionDynFlags dflags = do let prog = pgm_i dflags ++ flavour flavour - | WayProf `elem` ways dflags = "-prof" - | WayDyn `elem` ways dflags = "-dyn" - | otherwise = "" + | WayProf `S.member` ways dflags = "-prof" + | WayDyn `S.member` ways dflags = "-dyn" + | otherwise = "" msg = text "Starting " <> text prog tr <- if verbosity dflags >= 3 then return (logInfo dflags (defaultDumpStyle dflags) msg) @@ -617,7 +619,7 @@ setSessionDynFlags dflags = do { iservConfProgram = prog , iservConfOpts = getOpts dflags opt_i , iservConfProfiled = gopt Opt_SccProfilingOn dflags - , iservConfDynamic = WayDyn `elem` ways dflags + , iservConfDynamic = WayDyn `S.member` ways dflags , iservConfHook = createIservProcessHook (hooks dflags) , iservConfTrace = tr } diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index bfda490b85..55771b30a9 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -42,6 +42,7 @@ import MonadUtils import FastString import Util import GHC.Driver.Session +import GHC.Driver.Ways import ForeignCall import Demand ( isUsedOnce ) import PrimOp ( PrimCall(..), primOpWrapperId ) @@ -51,6 +52,7 @@ import PrelNames ( unsafeEqualityProofName ) import Data.List.NonEmpty (nonEmpty, toList) import Data.Maybe (fromMaybe) import Control.Monad (ap) +import qualified Data.Set as Set -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ @@ -230,7 +232,7 @@ coreToStg dflags this_mod pgm (_, (local_ccs, local_cc_stacks), pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm - prof = WayProf `elem` ways dflags + prof = WayProf `Set.member` ways dflags final_ccs | prof && gopt Opt_AutoSccsOnIndividualCafs dflags diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index f40cfeb286..859892cfbe 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -51,6 +51,7 @@ import Maybes import OrdList import ErrUtils import GHC.Driver.Session +import GHC.Driver.Ways import Util import Outputable import FastString @@ -183,7 +184,7 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons = initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env let cost_centres - | WayProf `elem` ways dflags + | WayProf `S.member` ways dflags = collectCostCentres this_mod binds | otherwise = S.empty diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index bbd501fb26..7b621ca3c4 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -20,6 +20,7 @@ import GhcPrelude import qualified GHC import GHC.Driver.Monad import GHC.Driver.Session +import GHC.Driver.Ways import Util import GHC.Driver.Types import qualified SysTools @@ -43,6 +44,7 @@ import System.IO.Error ( isEOFError ) import Control.Monad ( when ) import Data.Maybe ( isJust ) import Data.IORef +import qualified Data.Set as Set ----------------------------------------------------------------- -- @@ -62,8 +64,8 @@ doMkDependHS srcs = do -- way and .o/.hi extensions, regardless of any flags that might -- be specified. let dflags = dflags0 { - ways = [], - buildTag = waysTag [], + ways = Set.empty, + buildTag = waysTag Set.empty, hiSuf = "hi", objectSuf = "o" } diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs index 09eac60308..079bf6379f 100644 --- a/compiler/GHC/Driver/Packages.hs +++ b/compiler/GHC/Driver/Packages.hs @@ -71,6 +71,7 @@ import GhcPrelude import GHC.PackageDb import UnitInfo import GHC.Driver.Session +import GHC.Driver.Ways import Name ( Name, nameModule_maybe ) import UniqFM import UniqDFM @@ -1839,22 +1840,22 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) where ways0 = ways dflags - ways1 = filter (/= WayDyn) ways0 + ways1 = Set.filter (/= WayDyn) ways0 -- the name of a shared library is libHSfoo-ghc<version>.so -- we leave out the _dyn, because it is superfluous -- debug and profiled RTSs include support for -eventlog - ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1 - = filter (/= WayEventLog) ways1 + ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1 + = Set.filter (/= WayEventLog) ways1 | otherwise = ways1 - tag = waysTag (filter (not . wayRTSOnly) ways2) + tag = waysTag (Set.filter (not . wayRTSOnly) ways2) rts_tag = waysTag ways2 mkDynName x - | WayDyn `notElem` ways dflags = x - | "HS" `isPrefixOf` x = + | WayDyn `Set.notMember` ways dflags = x + | "HS" `isPrefixOf` x = x ++ '-':programName dflags ++ projectVersion dflags -- For non-Haskell libraries, we use the name "Cfoo". The .a -- file is libCfoo.a, and the .so is libfoo.so. That way the diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index d776e639b2..97dd1a6f07 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -64,8 +64,7 @@ module GHC.Driver.Session ( optimisationFlags, setFlagsFromEnvFile, - Way(..), waysTag, wayRTSOnly, addWay', updateWays, - wayGeneralFlags, wayUnsetGeneralFlags, + addWay', updateWays, thisPackage, thisComponentId, thisUnitIdInsts, @@ -533,7 +532,7 @@ data DynFlags = DynFlags { thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], -- ways - ways :: [Way], -- ^ Way flags from the command line + ways :: Set Way, -- ^ Way flags from the command line buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) -- For object splitting @@ -1495,10 +1494,10 @@ defaultDynFlags mySettings llvmConfig = cfgWeightInfo = defaultCfgWeights } -defaultWays :: Settings -> [Way] +defaultWays :: Settings -> Set Way defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) - then [WayDyn] - else [] + then Set.singleton WayDyn + else Set.empty -------------------------------------------------------------------------- -- @@ -2156,7 +2155,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do unless (allowed_combination theWays) $ liftIO $ throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ - intercalate "/" (map wayDesc theWays))) + intercalate "/" (map wayDesc (Set.toAscList theWays)))) let chooseOutput | isJust (outputFile dflags3) -- Only iff user specified -o ... @@ -2189,11 +2188,9 @@ putLogMsg dflags = log_action dflags dflags updateWays :: DynFlags -> DynFlags updateWays dflags - = let theWays = sort $ nub $ ways dflags - in dflags { - ways = theWays, - buildTag = waysTag (filter (not . wayRTSOnly) theWays) - } + = dflags { + buildTag = waysTag (Set.filter (not . wayRTSOnly) (ways dflags)) + } -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. @@ -4401,7 +4398,7 @@ addWay w = upd (addWay' w) addWay' :: Way -> DynFlags -> DynFlags addWay' w dflags0 = let platform = targetPlatform dflags0 - dflags1 = dflags0 { ways = w : ways dflags0 } + dflags1 = dflags0 { ways = Set.insert w (ways dflags0) } dflags2 = foldr setGeneralFlag' dflags1 (wayGeneralFlags platform w) dflags3 = foldr unSetGeneralFlag' dflags2 @@ -4409,7 +4406,7 @@ addWay' w dflags0 = let platform = targetPlatform dflags0 in dflags3 removeWayDyn :: DynP () -removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) }) +removeWayDyn = upd (\dfs -> dfs { ways = Set.filter (WayDyn /=) (ways dfs) }) -------------------------- setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () @@ -4832,7 +4829,7 @@ picCCOpts dflags = pieOpts ++ picOpts -- correctly. They need to reference data in the Haskell -- objects, but can't without -fPIC. See -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code - | gopt Opt_PIC dflags || WayDyn `elem` ways dflags -> + | gopt Opt_PIC dflags || WayDyn `Set.member` ways dflags -> ["-fPIC", "-U__PIC__", "-D__PIC__"] -- gcc may be configured to have PIC on by default, let's be -- explicit here, see #15847 @@ -5032,8 +5029,8 @@ makeDynFlagsConsistent dflags , not (gopt Opt_ExternalInterpreter dflags) , hostIsProfiled , isObjectTarget (hscTarget dflags) - , WayProf `notElem` ways dflags - = loop dflags{ways = WayProf : ways dflags} + , WayProf `Set.notMember` ways dflags + = loop dflags{ways = Set.insert WayProf (ways dflags)} "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" | otherwise = (dflags, []) diff --git a/compiler/GHC/Driver/Ways.hs b/compiler/GHC/Driver/Ways.hs index b295cc1a0d..1b9845850f 100644 --- a/compiler/GHC/Driver/Ways.hs +++ b/compiler/GHC/Driver/Ways.hs @@ -40,9 +40,9 @@ where import GhcPrelude import GHC.Platform import GHC.Driver.Flags -import Util (nubSort) import qualified Data.Set as Set +import Data.Set (Set) import Data.List (intersperse) import System.IO.Unsafe ( unsafeDupablePerformIO ) @@ -61,19 +61,18 @@ data Way -- | Check if a combination of ways is allowed -allowed_combination :: [Way] -> Bool +allowed_combination :: Set Way -> Bool allowed_combination ways = not disallowed where - s = Set.fromList ways - disallowed = or [ Set.member s x && Set.member s y + disallowed = or [ Set.member ways x && Set.member ways y | (x,y) <- couples ] -- List of disallowed couples of ways couples = [] -- we don't have any disallowed combination of ways nowadays -- | Unique build-tag associated to a list of ways -waysTag :: [Way] -> String -waysTag = concat . intersperse "_" . map wayTag . nubSort +waysTag :: Set Way -> String +waysTag = concat . intersperse "_" . map wayTag . Set.toAscList -- | Unique build-tag associated to a way wayTag :: Way -> String @@ -184,8 +183,8 @@ foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO Int -- | Return host "full" ways (i.e. ways that have an impact on the compilation, -- not RTS only ways). These ways must be used when compiling codes targeting -- the internal interpreter. -hostFullWays :: [Way] -hostFullWays = mconcat - [ if hostIsDynamic then [WayDyn] else [] - , if hostIsProfiled then [WayProf] else [] +hostFullWays :: Set Way +hostFullWays = Set.unions + [ if hostIsDynamic then Set.singleton WayDyn else Set.empty + , if hostIsProfiled then Set.singleton WayProf else Set.empty ] diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index 7e278dc07b..1eb6079c1e 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -14,6 +14,7 @@ module GHC.HsToCore.Usage ( import GhcPrelude import GHC.Driver.Session +import GHC.Driver.Ways import GHC.Driver.Types import TcRnTypes import Name diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index c8bc4e4124..331b460c06 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -66,6 +66,7 @@ import FileCleanup -- Standard libraries import Control.Monad +import qualified Data.Set as Set import Data.Char (isSpace) import Data.IORef import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) @@ -592,7 +593,7 @@ checkNonStdWay hsc_env srcspan | otherwise = return (Just (hostWayTag ++ "o")) where - targetFullWays = filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env)) + targetFullWays = Set.filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env)) hostWayTag = case waysTag hostFullWays of "" -> "" tag -> tag ++ "_" @@ -949,8 +950,8 @@ dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do -- Even if we're e.g. profiling, we still want -- the vanilla dynamic libraries, so we set the -- ways / build tag to be just WayDyn. - ways = [WayDyn], - buildTag = waysTag [WayDyn], + ways = Set.singleton WayDyn, + buildTag = waysTag (Set.singleton WayDyn), outputFile = Just soFile } -- link all "loaded packages" so symbols in those can be resolved diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index bbe889ba99..b2b13d424b 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -48,6 +48,7 @@ import Outputable import ErrUtils import GHC.Platform import GHC.Driver.Session +import GHC.Driver.Ways import Control.Monad.Trans.Except (runExceptT) import System.FilePath @@ -58,6 +59,7 @@ import SysTools.Info import SysTools.Tasks import SysTools.BaseDir import SysTools.Settings +import qualified Data.Set as Set {- Note [How GHC finds toolchain utilities] @@ -254,7 +256,7 @@ linkDynLib dflags0 o_files dep_packages | ( osElfTarget (platformOS (targetPlatform dflags)) || osMachOTarget (platformOS (targetPlatform dflags)) ) && dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags + WayDyn `Set.member` ways dflags = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] -- See Note [-Xlinker -rpath vs -Wl,-rpath] | otherwise = ["-L" ++ l] diff --git a/ghc/Main.hs b/ghc/Main.hs index 4c546b3afc..1ad2a26e86 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -82,6 +82,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except (throwE, runExceptT) import Data.Char import Data.List ( isPrefixOf, partition, intercalate ) +import qualified Data.Set as Set import Data.Maybe import Prelude @@ -349,12 +350,12 @@ checkOptions mode dflags srcs objs = do let unknown_opts = [ f | (f@('-':_), _) <- srcs ] when (notNull unknown_opts) (unknownFlagsErr unknown_opts) - when (notNull (filter wayRTSOnly (ways dflags)) + when (not (Set.null (Set.filter wayRTSOnly (ways dflags))) && isInterpretiveMode mode) $ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") -- -prof and --interactive are not a good combination - when ((filter (not . wayRTSOnly) (ways dflags) /= hostFullWays) + when ((Set.filter (not . wayRTSOnly) (ways dflags) /= hostFullWays) && isInterpretiveMode mode && not (gopt Opt_ExternalInterpreter dflags)) $ do throwGhcException (UsageError diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index bc10724677..64967c174d 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -39,6 +39,7 @@ Executable ghc directory >= 1 && < 1.4, process >= 1 && < 1.7, filepath >= 1 && < 1.5, + containers >= 0.5 && < 0.7, transformers == 0.5.*, ghc-boot == @ProjectVersionMunged@, ghc == @ProjectVersionMunged@ @@ -57,7 +58,6 @@ Executable ghc if flag(ghci) -- NB: this is never built by the bootstrapping GHC+libraries Build-depends: - containers >= 0.5 && < 0.7, deepseq == 1.4.*, ghc-prim >= 0.5.0 && < 0.7, ghci == @ProjectVersionMunged@, |