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

10 files changed, 85 insertions, 38 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 134580c653..59f49453ed 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -639,11 +639,13 @@ checkBrokenTablesNextToCode' logger dflags
 setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
 setSessionDynFlags dflags0 = do
   logger <- getLogger
-  dflags <- checkNewDynFlags logger dflags0
+  dflags1 <- checkNewDynFlags logger dflags0
   hsc_env <- getSession
   let old_unit_env    = hsc_unit_env hsc_env
   let cached_unit_dbs = ue_unit_dbs old_unit_env
-  (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags cached_unit_dbs
+  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs
+
+  dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
 
   -- Interpreter
   interp <- if gopt Opt_ExternalInterpreter dflags
@@ -711,27 +713,30 @@ setProgramDynFlags dflags = setProgramDynFlags_ True dflags
 setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
 setProgramDynFlags_ invalidate_needed dflags = do
   logger <- getLogger
-  dflags' <- checkNewDynFlags logger dflags
+  dflags0 <- checkNewDynFlags logger dflags
   dflags_prev <- getProgramDynFlags
-  let changed = packageFlagsChanged dflags_prev dflags'
+  let changed = packageFlagsChanged dflags_prev dflags0
   if changed
     then do
         old_unit_env <- hsc_unit_env <$> getSession
         let cached_unit_dbs = ue_unit_dbs old_unit_env
-        (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags' cached_unit_dbs
+        (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 cached_unit_dbs
+
+        dflags1 <- liftIO $ updatePlatformConstants dflags0 mconstants
+
         let unit_env = UnitEnv
-              { ue_platform  = targetPlatform dflags'
-              , ue_namever   = ghcNameVersion dflags'
+              { ue_platform  = targetPlatform dflags1
+              , ue_namever   = ghcNameVersion dflags1
               , ue_home_unit = Just home_unit
               , ue_hpt       = ue_hpt old_unit_env
               , ue_eps       = ue_eps old_unit_env
               , ue_units     = unit_state
               , ue_unit_dbs  = Just dbs
               }
-        modifySession $ \h -> h{ hsc_dflags   = dflags'
+        modifySession $ \h -> h{ hsc_dflags   = dflags1
                                , hsc_unit_env = unit_env
                                }
-    else modifySession $ \h -> h{ hsc_dflags = dflags' }
+    else modifySession $ \h -> h{ hsc_dflags = dflags0 }
   when invalidate_needed $ invalidateModSummaryCache
   return changed
 
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
diff --git a/testsuite/tests/codeGen/should_run/T13825-unit.hs b/testsuite/tests/codeGen/should_run/T13825-unit.hs
index c689a3a676..70b30f0d73 100644
--- a/testsuite/tests/codeGen/should_run/T13825-unit.hs
+++ b/testsuite/tests/codeGen/should_run/T13825-unit.hs
@@ -13,7 +13,9 @@ import GHC.Platform
 main :: IO ()
 main = do
     [libdir] <- getArgs
-    runGhc (Just libdir) tests
+    runGhc (Just libdir) $ do
+      setSessionDynFlags =<< getDynFlags
+      tests
 
 
 -- How to read tests:
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index 496c4dc6a0..b956f2579a 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -64,7 +64,10 @@ main = do
 
     --get a GHC context and run the tests
     runGhc (Just libdir) $ do
-        dflags <- fmap setOptions getDynFlags
+        dflags0 <- fmap setOptions getDynFlags
+        setSessionDynFlags dflags0
+
+        dflags <- getDynFlags
         logger <- getLogger
         reifyGhc $ \_ -> do
             us <- unitTestUniqSupply