diff options
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Binary.hs | 41 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Load.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Platform/Profile.hs | 36 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 |
5 files changed, 61 insertions, 26 deletions
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 8ed062de35..b664f23ec8 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -63,7 +63,7 @@ module GHC.Driver.Session ( optimisationFlags, setFlagsFromEnvFile, - addWay', + addWay', targetProfile, homeUnit, mkHomeModule, isHomeModule, @@ -4866,6 +4866,10 @@ bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` platformWordSizeInBytes platform wordAlignment :: Platform -> Alignment wordAlignment platform = alignmentOf (platformWordSizeInBytes platform) +-- | Get target profile +targetProfile :: DynFlags -> Profile +targetProfile dflags = Profile (targetPlatform dflags) (ways dflags) + tAG_MASK :: DynFlags -> Int tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index 5e9cbf15a2..5eddac0373 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -43,7 +43,7 @@ import GHC.Driver.Types import GHC.Unit import GHC.Types.Name import GHC.Driver.Session -import GHC.Platform.Ways +import GHC.Platform.Profile import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Utils.Panic @@ -58,7 +58,6 @@ import GHC.Data.FastString import GHC.Settings.Constants import GHC.Utils.Misc -import Data.Set (Set) import Data.Array import Data.Array.ST import Data.Array.Unsafe @@ -89,14 +88,15 @@ readBinIface :: CheckHiWay -> TraceBinIFace -> FilePath readBinIface checkHiWay traceBinIFaceReading hi_path = do ncu <- mkNameCacheUpdater dflags <- getDynFlags - liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu + let profile = targetProfile dflags + liftIO $ readBinIface_ profile checkHiWay traceBinIFaceReading hi_path ncu -- | Read an interface file in 'IO'. -readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFace -> FilePath +readBinIface_ :: Profile -> CheckHiWay -> TraceBinIFace -> FilePath -> NameCacheUpdater -> IO ModIface -readBinIface_ dflags checkHiWay traceBinIFace hi_path ncu = do - let platform = targetPlatform dflags +readBinIface_ profile checkHiWay traceBinIFace hi_path ncu = do + let platform = profilePlatform profile wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () wantedGot what wanted got ppr' = @@ -124,17 +124,17 @@ readBinIface_ dflags checkHiWay traceBinIFace hi_path ncu = do errorOnMismatch "magic number mismatch: old/corrupt interface file?" (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic) - -- Check the interface file version and ways. + -- Check the interface file version and profile tag. check_ver <- get bh let our_ver = show hiVersion wantedGot "Version" our_ver check_ver text errorOnMismatch "mismatched interface file versions" our_ver check_ver - check_way <- get bh - let way_descr = getWayDescr platform (ways dflags) - wantedGot "Way" way_descr check_way ppr + check_tag <- get bh + let tag = profileBuildTag profile + wantedGot "Way" tag check_tag ppr when (checkHiWay == CheckHiWay) $ - errorOnMismatch "mismatched interface file ways" way_descr check_way + errorOnMismatch "mismatched interface file profile tag" tag check_tag extFields_p <- get bh @@ -178,16 +178,16 @@ getWithUserData ncu bh = do get bh -- | Write an interface file -writeBinIface :: DynFlags -> TraceBinIFace -> FilePath -> ModIface -> IO () -writeBinIface dflags traceBinIface hi_path mod_iface = do +writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO () +writeBinIface profile traceBinIface hi_path mod_iface = do bh <- openBinMem initBinMemSize - let platform = targetPlatform dflags + let platform = profilePlatform profile put_ bh (binaryInterfaceMagic platform) - -- The version and way descriptor go next + -- The version and profile tag go next put_ bh (show hiVersion) - let way_descr = getWayDescr platform (ways dflags) - put_ bh way_descr + let tag = profileBuildTag profile + put_ bh tag extFields_p_p <- tellBin bh put_ bh extFields_p_p @@ -429,10 +429,3 @@ data BinDictionary = BinDictionary { -- indexed by FastString } -getWayDescr :: Platform -> Set Way -> String -getWayDescr platform ws - | platformUnregisterised platform = 'u':tag - | otherwise = tag - where tag = waysBuildTag ws - -- if this is an unregisterised build, make sure our interfaces - -- can't be used by a registerised build. diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index fa148dc954..119a0e23c4 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -984,7 +984,8 @@ writeIface :: DynFlags -> FilePath -> ModIface -> IO () writeIface dflags hi_file_path new_iface = do createDirectoryIfMissing True (takeDirectory hi_file_path) let printer = TraceBinIFace (debugTraceMsg dflags 3) - writeBinIface dflags printer hi_file_path new_iface + profile = targetProfile dflags + writeBinIface profile printer hi_file_path new_iface -- @readIface@ tries just the one file. readIface :: Module -> FilePath diff --git a/compiler/GHC/Platform/Profile.hs b/compiler/GHC/Platform/Profile.hs new file mode 100644 index 0000000000..d484a1ebc4 --- /dev/null +++ b/compiler/GHC/Platform/Profile.hs @@ -0,0 +1,36 @@ +-- | Platform profiles +module GHC.Platform.Profile + ( Profile (..) + , profileBuildTag + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Ways + +import Data.Set + +-- | A platform profile fully describes the kind of objects that are generated +-- for a platform. +-- +-- 'Platform' doesn't fully describe the ABI of an object. Compiler ways +-- (profiling, debug, dynamic) also modify the ABI. +-- +data Profile = Profile + { profilePlatform :: !Platform -- ^ Platform + , profileWays :: !(Set Way) -- ^ Ways + } + +-- | Unique build tag for the profile +profileBuildTag :: Profile -> String +profileBuildTag profile + -- profiles using unregisterised convention are not binary compatible with + -- those that don't. Make sure to make it apparent in the tag so that our + -- interface files can't be mismatched by mistake. + | platformUnregisterised platform = 'u':wayTag + | otherwise = wayTag + where + platform = profilePlatform profile + wayTag = waysBuildTag (profileWays profile) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index db48f60105..5c153817e7 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -182,6 +182,7 @@ Library GHC.Driver.Hooks GHC.Driver.Flags GHC.Platform.Ways + GHC.Platform.Profile GHC.Types.Id GHC.Types.Id.Info GHC.Core.Predicate |