summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC.hs23
-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
-rw-r--r--testsuite/tests/codeGen/should_run/T13825-unit.hs4
-rw-r--r--testsuite/tests/regalloc/regalloc_unit_tests.hs5
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
View Lorry Controller Status