summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2021-03-25 17:25:31 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-04-10 05:31:14 -0400
commit085983e63bfe6af23f8b85fbfcca8db4872d2f60 (patch)
tree0d41072c2830e5825f4e6f28c1ed528e29ca54dd /compiler/GHC
parent9c762f27d5468ab692e390b16420c9e304993993 (diff)
downloadhaskell-085983e63bfe6af23f8b85fbfcca8db4872d2f60.tar.gz
Read constants header instead of global platformConstants
With this patch we switch from reading the globally installed platformConstants file to reading the DerivedConstants.h header file that is bundled in the RTS unit. When we build the RTS unit itself, we get it from its includes directories. The new parser is more efficient and strict than the Read instance for PlatformConstants and we get about 2.2MB less allocations in every cases. However it only really shows in tests that don't allocate much, hence the following metric decreases. Metric Decrease: Naperian T10421 T10547 T12150 T12234 T12425 T13035 T18304 T18923 T5837 T6048 T18140
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Driver/Backpack.hs16
-rw-r--r--compiler/GHC/Driver/Pipeline.hs12
-rw-r--r--compiler/GHC/Driver/Session.hs9
-rw-r--r--compiler/GHC/Platform.hs9
-rw-r--r--compiler/GHC/Settings.hs1
-rw-r--r--compiler/GHC/Settings/IO.hs15
-rw-r--r--compiler/GHC/Unit/State.hs29
7 files changed, 64 insertions, 27 deletions
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 5c45858570..b781685e91 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -417,19 +417,24 @@ addUnit :: GhcMonad m => UnitInfo -> m ()
addUnit u = do
hsc_env <- getSession
logger <- getLogger
+ let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
let newdb = UnitDatabase
- { unitDatabasePath = "(in memory " ++ showSDoc (hsc_dflags hsc_env) (ppr (unitId u)) ++ ")"
+ { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit) <- liftIO $ initUnits logger (hsc_dflags hsc_env) (Just newdbs)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs)
+
+ -- update platform constants
+ dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
+
let unit_env = UnitEnv
- { ue_platform = targetPlatform (hsc_dflags hsc_env)
- , ue_namever = ghcNameVersion (hsc_dflags hsc_env)
+ { ue_platform = targetPlatform dflags
+ , ue_namever = ghcNameVersion dflags
, ue_home_unit = Just home_unit
, ue_hpt = ue_hpt old_unit_env
, ue_eps = ue_eps old_unit_env
@@ -437,7 +442,8 @@ addUnit u = do
, ue_unit_dbs = Just dbs
}
setSession $ hsc_env
- { hsc_unit_env = unit_env
+ { hsc_dflags = dflags
+ , hsc_unit_env = unit_env
}
compileInclude :: Int -> (Int, Unit) -> BkpM ()
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index e79d1ecab9..0a75b62248 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -814,19 +814,21 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
| otherwise -> do
debugTraceMsg logger dflags 4
(text "Running the full pipeline again for -dynamic-too")
- let dflags' = flip gopt_unset Opt_BuildDynamicToo
+ let dflags0 = flip gopt_unset Opt_BuildDynamicToo
$ setDynamicNow
$ dflags
- hsc_env' <- newHscEnv dflags'
- (dbs,unit_state,home_unit) <- initUnits logger dflags' Nothing
- unit_env0 <- initUnitEnv (ghcNameVersion dflags') (targetPlatform dflags')
+ hsc_env' <- newHscEnv dflags0
+ (dbs,unit_state,home_unit,mconstants) <- initUnits logger dflags0 Nothing
+ dflags1 <- updatePlatformConstants dflags0 mconstants
+ unit_env0 <- initUnitEnv (ghcNameVersion dflags1) (targetPlatform dflags1)
let unit_env = unit_env0
{ ue_home_unit = Just home_unit
, ue_units = unit_state
, ue_unit_dbs = Just dbs
}
let hsc_env'' = hsc_env'
- { hsc_unit_env = unit_env
+ { hsc_dflags = dflags1
+ , hsc_unit_env = unit_env
}
_ <- runPipeline' start_phase hsc_env'' env input_fn'
maybe_loc foreign_os
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index ce26b0e984..969d63a54b 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -144,6 +144,7 @@ module GHC.Driver.Session (
opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,
opt_P_signature,
opt_windres, opt_lo, opt_lc, opt_lcc,
+ updatePlatformConstants,
-- ** Manipulating DynFlags
addPluginModuleName,
@@ -222,6 +223,7 @@ import GHC.Prelude
import GHC.Platform
import GHC.Platform.Ways
import GHC.Platform.Profile
+
import GHC.UniqueSubdir (uniqueSubdir)
import GHC.Unit.Types
import GHC.Unit.Parser
@@ -744,7 +746,6 @@ settings dflags = Settings
, sTargetPlatform = targetPlatform dflags
, sToolSettings = toolSettings dflags
, sPlatformMisc = platformMisc dflags
- , sPlatformConstants = platformConstants (targetPlatform dflags)
, sRawSettings = rawSettings dflags
}
@@ -4993,3 +4994,9 @@ pprDynFlagsDiff d1 d2 =
, text "Removed extension flags:"
, text $ show $ EnumSet.toList $ ext_removed
]
+
+updatePlatformConstants :: DynFlags -> Maybe PlatformConstants -> IO DynFlags
+updatePlatformConstants dflags mconstants = do
+ let platform1 = (targetPlatform dflags) { platform_constants = mconstants }
+ let dflags1 = dflags { targetPlatform = platform1 }
+ return dflags1
diff --git a/compiler/GHC/Platform.hs b/compiler/GHC/Platform.hs
index 5e54e2111e..5ce843046b 100644
--- a/compiler/GHC/Platform.hs
+++ b/compiler/GHC/Platform.hs
@@ -3,6 +3,7 @@
-- | Platform description
module GHC.Platform
( Platform (..)
+ , platformConstants
, PlatformWordSize(..)
, PlatformConstants(..)
, platformArch
@@ -45,6 +46,7 @@ import GHC.Read
import GHC.ByteOrder (ByteOrder(..))
import GHC.Platform.Constants
import GHC.Platform.ArchOS
+import GHC.Utils.Panic.Plain
import Data.Word
import Data.Int
@@ -67,11 +69,16 @@ data Platform = Platform
-- ^ Determines whether we will be compiling info tables that reside just
-- before the entry code, or with an indirection to the entry code. See
-- TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h.
- , platformConstants :: !PlatformConstants
+ , platform_constants :: !(Maybe PlatformConstants)
-- ^ Constants such as structure offsets, type sizes, etc.
}
deriving (Read, Show, Eq)
+platformConstants :: Platform -> PlatformConstants
+platformConstants platform = case platform_constants platform of
+ Nothing -> panic "Platform constants not available!"
+ Just c -> c
+
data PlatformWordSize
= PW4 -- ^ A 32-bit platform
| PW8 -- ^ A 64-bit platform
diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs
index 364c481cf6..13b7fd05c2 100644
--- a/compiler/GHC/Settings.hs
+++ b/compiler/GHC/Settings.hs
@@ -77,7 +77,6 @@ data Settings = Settings
, sTargetPlatform :: Platform -- Filled in by SysTools
, sToolSettings :: {-# UNPACK #-} !ToolSettings
, sPlatformMisc :: {-# UNPACK #-} !PlatformMisc
- , sPlatformConstants :: PlatformConstants
-- You shouldn't need to look things up in rawSettings directly.
-- They should have their own fields instead.
diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs
index cd1c210ee7..51f101aaad 100644
--- a/compiler/GHC/Settings/IO.hs
+++ b/compiler/GHC/Settings/IO.hs
@@ -48,7 +48,6 @@ initSettings top_dir = do
libexec :: FilePath -> FilePath
libexec file = top_dir </> "bin" </> file
settingsFile = installed "settings"
- platformConstantsFile = installed "platformConstants"
readFileSafe :: FilePath -> ExceptT SettingsError m String
readFileSafe path = liftIO (doesFileExist path) >>= \case
@@ -56,16 +55,11 @@ initSettings top_dir = do
False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path
settingsStr <- readFileSafe settingsFile
- platformConstantsStr <- readFileSafe platformConstantsFile
settingsList <- case maybeReadFuzzy settingsStr of
Just s -> pure s
Nothing -> throwE $ SettingsError_BadData $
"Can't parse " ++ show settingsFile
let mySettings = Map.fromList settingsList
- platformConstants <- case maybeReadFuzzy platformConstantsStr of
- Just s -> pure s
- Nothing -> throwE $ SettingsError_BadData $
- "Can't parse " ++ show platformConstantsFile
-- See Note [Settings file] for a little more about this file. We're
-- just partially applying those functions and throwing 'Left's; they're
-- written in a very portable style to keep ghc-boot light.
@@ -91,7 +85,7 @@ initSettings top_dir = do
cpp_prog <- getToolSetting "Haskell CPP command"
cpp_args_str <- getSetting "Haskell CPP flags"
- platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings platformConstants
+ platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings
let unreg_cc_args = if platformUnregisterised platform
then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
@@ -227,17 +221,14 @@ initSettings top_dir = do
, platformMisc_llvmTarget = llvmTarget
}
- , sPlatformConstants = platformConstants
-
, sRawSettings = settingsList
}
getTargetPlatform
:: FilePath -- ^ Settings filepath (for error messages)
-> RawSettings -- ^ Raw settings file contents
- -> PlatformConstants -- ^ Platform constants
-> Either String Platform
-getTargetPlatform settingsFile settings constants = do
+getTargetPlatform settingsFile settings = do
let
getBooleanSetting = getRawBooleanSetting settingsFile settings
readSetting :: (Show a, Read a) => String -> Either String a
@@ -265,5 +256,5 @@ getTargetPlatform settingsFile settings constants = do
, platformIsCrossCompiling = crossCompiling
, platformLeadingUnderscore = targetLeadingUnderscore
, platformTablesNextToCode = tablesNextToCode
- , platformConstants = constants
+ , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit
}
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 92b38443c8..4a1cd29b25 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -77,6 +77,7 @@ import GHC.Driver.Session
import GHC.Platform
import GHC.Platform.Ways
+import GHC.Platform.Constants
import GHC.Unit.Database
import GHC.Unit.Info
@@ -575,7 +576,7 @@ listUnitInfo state = Map.elems (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit)
+initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
initUnits logger dflags cached_dbs = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
@@ -595,7 +596,31 @@ initUnits logger dflags cached_dbs = do
(homeUnitInstanceOf_ dflags)
(homeUnitInstantiations_ dflags)
- return (dbs,unit_state,home_unit)
+ -- try to find platform constants
+ mconstants <- do
+ let
+ try_parse d = do
+ let p = d </> "DerivedConstants.h"
+ doesFileExist p >>= \case
+ True -> Just <$> parseConstantsHeader p
+ False -> return Nothing
+
+ find_constants [] = return Nothing
+ find_constants (x:xs) = try_parse x >>= \case
+ Nothing -> find_constants xs
+ Just c -> return (Just c)
+
+ if homeUnitId_ dflags == rtsUnitId
+ then do
+ -- we're building the RTS! Try to find the header in its includes
+ find_constants (includePathsGlobal (includePaths dflags))
+ else
+ -- try to find the platform constants in the RTS unit
+ case lookupUnitId unit_state rtsUnitId of
+ Nothing -> return Nothing
+ Just info -> find_constants (fmap ST.unpack (unitIncludeDirs info))
+
+ return (dbs,unit_state,home_unit,mconstants)
mkHomeUnit
:: UnitState