Add GHC.Platform.Profile

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