summaryrefslogtreecommitdiff
path: root/compiler/GHC/Iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Iface')
-rw-r--r--compiler/GHC/Iface/Binary.hs8
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs2
-rw-r--r--compiler/GHC/Iface/Ext/Binary.hs5
-rw-r--r--compiler/GHC/Iface/Ext/Fields.hs24
-rw-r--r--compiler/GHC/Iface/Ext/Types.hs2
-rw-r--r--compiler/GHC/Iface/Load.hs11
-rw-r--r--compiler/GHC/Iface/Recomp.hs2
-rw-r--r--compiler/GHC/Iface/Recomp/Flags.hs14
-rw-r--r--compiler/GHC/Iface/Type.hs8
9 files changed, 42 insertions, 34 deletions
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index a1611fe263..815ee817e4 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -106,12 +106,12 @@ readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
(unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic)
-- Check the interface file version and profile tag.
- check_ver <- get bh
+ check_ver <- map getSerialisedChar <$> get bh
let our_ver = show hiVersion
wantedGot "Version" our_ver check_ver text
errorOnMismatch "mismatched interface file versions" our_ver check_ver
- check_tag <- get bh
+ check_tag <- map getSerialisedChar <$> get bh
let tag = profileBuildTag profile
wantedGot "Way" tag check_tag text
when (checkHiWay == CheckHiWay) $
@@ -179,8 +179,8 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
put_ bh (binaryInterfaceMagic platform)
-- The version, profile tag, and source hash go next
- put_ bh (show hiVersion)
- let tag = profileBuildTag profile
+ put_ bh (map SerialisableChar $ show hiVersion)
+ let tag = map SerialisableChar $ profileBuildTag profile
put_ bh tag
put_ bh (mi_src_hash mod_iface)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 24a68e63c4..5af938cbe7 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -303,7 +303,7 @@ mkHieFileWithSource src_file src ms ts rs =
tcs = tcg_tcs ts
(asts',arr) = getCompressedAsts tc_binds rs top_ev_binds insts tcs in
HieFile
- { hie_hs_file = src_file
+ { hie_hs_file = mkFastString src_file
, hie_module = ms_mod ms
, hie_types = arr
, hie_asts = asts'
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 6474fbeb8e..e537d2ecd8 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -32,6 +32,7 @@ import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.FM
+import Data.Bifunctor (first)
import qualified Data.Array as A
import qualified Data.Array.IO as A
import qualified Data.Array.Unsafe as A
@@ -344,7 +345,7 @@ putHieName bh (LocalName occName span) = do
put_ bh (occName, BinSrcSpan span)
putHieName bh (KnownKeyName uniq) = do
putByte bh 2
- put_ bh $ unpkUnique uniq
+ put_ bh $ (first SerialisableChar $ unpkUnique uniq)
getHieName :: BinHandle -> IO HieName
getHieName bh = do
@@ -358,5 +359,5 @@ getHieName bh = do
return $ LocalName occ $ unBinSrcSpan span
2 -> do
(c,i) <- get bh
- return $ KnownKeyName $ mkUnique c i
+ return $ KnownKeyName $ mkUnique (getSerialisedChar c) i
_ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag"
diff --git a/compiler/GHC/Iface/Ext/Fields.hs b/compiler/GHC/Iface/Ext/Fields.hs
index 37322303d8..76cd936bdc 100644
--- a/compiler/GHC/Iface/Ext/Fields.hs
+++ b/compiler/GHC/Iface/Ext/Fields.hs
@@ -15,23 +15,25 @@ where
import GHC.Prelude
import GHC.Utils.Binary
+import GHC.Data.FastString
+import GHC.Types.Unique.Map
+import Data.Function (on)
+import Data.List (sortBy)
import Control.Monad
-import Data.Map ( Map )
-import qualified Data.Map as Map
import Control.DeepSeq
-type FieldName = String
+type FieldName = FastString
-newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) }
+newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (UniqMap FastString BinData) }
instance Binary ExtensibleFields where
put_ bh (ExtensibleFields fs) = do
- put_ bh (Map.size fs :: Int)
+ put_ bh (sizeUniqMap fs :: Int)
-- Put the names of each field, and reserve a space
-- for a payload pointer after each name:
- header_entries <- forM (Map.toList fs) $ \(name, dat) -> do
+ header_entries <- forM (sortBy (lexicalCompareFS `on` fst) $ nonDetUniqMapToList fs) $ \(name, dat) -> do
put_ bh name
field_p_p <- tellBin bh
put_ bh field_p_p
@@ -58,13 +60,13 @@ instance Binary ExtensibleFields where
dat <- get bh
return (name, dat)
- return . ExtensibleFields . Map.fromList $ fields
+ return . ExtensibleFields . listToUniqMap $ fields
instance NFData ExtensibleFields where
rnf (ExtensibleFields fs) = rnf fs
emptyExtensibleFields :: ExtensibleFields
-emptyExtensibleFields = ExtensibleFields Map.empty
+emptyExtensibleFields = ExtensibleFields emptyUniqMap
--------------------------------------------------------------------------------
-- | Reading
@@ -74,7 +76,7 @@ readField name = readFieldWith name get
readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
- Map.lookup name (getExtensibleFields fields)
+ lookupUniqMap (getExtensibleFields fields) name
--------------------------------------------------------------------------------
-- | Writing
@@ -88,7 +90,7 @@ writeFieldWith name write fields = do
write bh
--
bd <- handleData bh
- return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)
+ return $ ExtensibleFields (addToUniqMap (getExtensibleFields fields) name bd)
deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
-deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs
+deleteField name (ExtensibleFields fs) = ExtensibleFields $ delFromUniqMap fs name
diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs
index b8a398465c..6fe5a9f7af 100644
--- a/compiler/GHC/Iface/Ext/Types.hs
+++ b/compiler/GHC/Iface/Ext/Types.hs
@@ -65,7 +65,7 @@ Besides saving compilation cycles, @.hie@ files also offer a more stable
interface than the GHC API.
-}
data HieFile = HieFile
- { hie_hs_file :: FilePath
+ { hie_hs_file :: FastString
-- ^ Initial Haskell source file path
, hie_module :: Module
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index f5628e8fb6..819b943d9a 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -94,6 +94,7 @@ import GHC.Types.SourceFile
import GHC.Types.SafeHaskell
import GHC.Types.TypeEnv
import GHC.Types.Unique.DSet
+import GHC.Types.Unique.Map
import GHC.Types.SrcLoc
import GHC.Types.TyThing
import GHC.Types.PkgQual
@@ -109,10 +110,12 @@ import GHC.Unit.Home.ModInfo
import GHC.Unit.Finder
import GHC.Unit.Env
-import GHC.Data.Maybe
+import GHC.Data.FastString
import Control.Monad
-import Data.Map ( toList )
+import Data.List (sortBy)
+import Data.Function (on)
+import GHC.Data.Maybe
import System.FilePath
import System.Directory
import GHC.Driver.Env.KnotVars
@@ -1219,6 +1222,6 @@ pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedVal
= ppr target <+> text "annotated by" <+> ppr serialized
pprExtensibleFields :: ExtensibleFields -> SDoc
-pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs
+pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ sortBy (lexicalCompareFS `on` fst) $ nonDetUniqMapToList fs
where
- pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"
+ pprField (name, (BinData size _data)) = ftext name <+> text "-" <+> ppr size <+> text "bytes"
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 298e876595..afb1ef922c 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -777,7 +777,7 @@ checkModUsage fc UsageFile{ usg_file_path = file,
else return UpToDate
where
reason = FileChanged $ unpackFS file
- recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel
+ recomp = needsRecompileBecause $ fromMaybe reason $ fmap (CustomReason . unpackFS) mlabel
handler = if debugIsOn
then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
else \_ -> return recomp -- if we can't find the file, just recompile, don't fail
diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs
index e8d13bfa0d..024320f679 100644
--- a/compiler/GHC/Iface/Recomp/Flags.hs
+++ b/compiler/GHC/Iface/Recomp/Flags.hs
@@ -8,6 +8,7 @@ module GHC.Iface.Recomp.Flags (
, fingerprintHpcFlags
) where
+import Data.Bifunctor (first)
import GHC.Prelude
import GHC.Driver.Session
@@ -36,7 +37,8 @@ fingerprintDynFlags :: HscEnv -> Module
fingerprintDynFlags hsc_env this_mod nameio =
let dflags@DynFlags{..} = hsc_dflags hsc_env
- mainis = if mainModIs (hsc_HUE hsc_env) == this_mod then Just mainFunIs else Nothing
+ serialisableString = map SerialisableChar
+ mainis = if mainModIs (hsc_HUE hsc_env) == this_mod then Just (fmap serialisableString mainFunIs) else Nothing
-- see #5878
-- pkgopts = (homeUnit home_unit, sort $ packageFlags dflags)
safeHs = setSafeMode safeHaskell
@@ -51,14 +53,14 @@ fingerprintDynFlags hsc_env this_mod nameio =
includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] }
-- -I, -D and -U flags affect CPP
- cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit
+ cpp = ( map (serialisableString . normalise) $ flattenIncludes includePathsMinusImplicit
-- normalise: eliminate spurious differences due to "./foo" vs "foo"
- , picPOpts dflags
- , opt_P_signature dflags)
+ , map serialisableString $ picPOpts dflags
+ , first (map serialisableString) $ opt_P_signature dflags)
-- See Note [Repeated -optP hashing]
-- Note [path flags and recompilation]
- paths = [ hcSuf ]
+ paths = map serialisableString [ hcSuf ]
-- -fprof-auto etc.
prof = if sccProfilingEnabled dflags then fromEnum profAuto else 0
@@ -102,7 +104,7 @@ fingerprintHpcFlags dflags@DynFlags{..} nameio =
let
-- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798
-- hpcDir is output-only, so we should recompile if it changes
- hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing
+ hpc = if gopt Opt_Hpc dflags then Just (map SerialisableChar hpcDir) else Nothing
in computeFingerprint nameio hpc
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 1796539cd5..669e998e38 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -402,7 +402,7 @@ data IfaceCoercion
data IfaceUnivCoProv
= IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
- | IfacePluginProv String
+ | IfacePluginProv FastString
| IfaceCorePrepProv Bool -- See defn of CorePrepProv
{- Note [Holes in IfaceCoercion]
@@ -1886,7 +1886,7 @@ pprIfaceUnivCoProv (IfacePhantomProv co)
pprIfaceUnivCoProv (IfaceProofIrrelProv co)
= text "irrel" <+> pprParendIfaceCoercion co
pprIfaceUnivCoProv (IfacePluginProv s)
- = text "plugin" <+> doubleQuotes (text s)
+ = text "plugin" <+> doubleQuotes (ftext s)
pprIfaceUnivCoProv (IfaceCorePrepProv _)
= text "CorePrep"
@@ -1952,7 +1952,7 @@ instance Outputable IfaceTyLit where
instance Binary IfaceTyLit where
put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
- put_ bh (IfaceCharTyLit n) = putByte bh 3 >> put_ bh n
+ put_ bh (IfaceCharTyLit n) = putByte bh 3 >> put_ bh (SerialisableChar n)
get bh =
do tag <- getByte bh
@@ -1962,7 +1962,7 @@ instance Binary IfaceTyLit where
2 -> do { n <- get bh
; return (IfaceStrTyLit n) }
3 -> do { n <- get bh
- ; return (IfaceCharTyLit n) }
+ ; return (IfaceCharTyLit $ getSerialisedChar n) }
_ -> panic ("get IfaceTyLit " ++ show tag)
instance Binary IfaceAppArgs where
View Lorry Controller Status