Commit a6989971 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Use a Set to represent Ways

Should make `member` queries faster and avoid messing up with missing
`nubSort`.

Metric Increase:
    hie002
parent bc41e471
Pipeline #16617 passed with stages
in 681 minutes and 11 seconds
......@@ -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
}
......
......@@ -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
......
......@@ -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
......
......@@ -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"
}
......
......@@ -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
......
......@@ -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, [])
......
......@@ -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
]
......@@ -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
......
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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@,
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment