diff options
author | Owen Shepherd <owen@owen.cafe> | 2022-10-11 16:18:56 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-10-27 13:54:33 -0400 |
commit | 223e159d7af546a7176eef073e6e599b3c261c9c (patch) | |
tree | 2d9039801ae577d2e51e5b7a4c94ebaeaa1b1117 | |
parent | f60a1a62bf88ec787a5b5d1725129a24b6b81f4a (diff) | |
download | haskell-223e159d7af546a7176eef073e6e599b3c261c9c.tar.gz |
Remove source location information from interface files
This change aims to minimize source location information leaking
into interface files, which makes ABI hashes dependent on the
build location.
The `Binary (Located a)` instance has been removed completely.
It seems that the HIE interface still needs the ability to
serialize SrcSpans, but by wrapping the instances, it should
be a lot more difficult to inadvertently add source location
information.
-rw-r--r-- | compiler/GHC/Data/BooleanFormula.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Hs/Doc.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Hs/DocString.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Iface/Ext/Binary.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Iface/Ext/Types.hs | 36 | ||||
-rw-r--r-- | compiler/GHC/Parser/Annotation.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/Unit/Module/Warnings.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Utils/Binary.hs | 60 |
8 files changed, 88 insertions, 72 deletions
diff --git a/compiler/GHC/Data/BooleanFormula.hs b/compiler/GHC/Data/BooleanFormula.hs index bedb360875..f01aa0339d 100644 --- a/compiler/GHC/Data/BooleanFormula.hs +++ b/compiler/GHC/Data/BooleanFormula.hs @@ -25,7 +25,7 @@ import Data.Data import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Binary -import GHC.Parser.Annotation ( LocatedL ) +import GHC.Parser.Annotation ( LocatedL, noLocA ) import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Set @@ -251,14 +251,14 @@ pprBooleanFormulaNormal = go instance Binary a => Binary (BooleanFormula a) where put_ bh (Var x) = putByte bh 0 >> put_ bh x - put_ bh (And xs) = putByte bh 1 >> put_ bh xs - put_ bh (Or xs) = putByte bh 2 >> put_ bh xs - put_ bh (Parens x) = putByte bh 3 >> put_ bh x + put_ bh (And xs) = putByte bh 1 >> put_ bh (unLoc <$> xs) + put_ bh (Or xs) = putByte bh 2 >> put_ bh (unLoc <$> xs) + put_ bh (Parens x) = putByte bh 3 >> put_ bh (unLoc x) get bh = do h <- getByte bh case h of - 0 -> Var <$> get bh - 1 -> And <$> get bh - 2 -> Or <$> get bh - _ -> Parens <$> get bh + 0 -> Var <$> get bh + 1 -> And . fmap noLocA <$> get bh + 2 -> Or . fmap noLocA <$> get bh + _ -> Parens . noLocA <$> get bh diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 4873eaa367..948341f89f 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -85,9 +85,9 @@ instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where put_ bh (WithHsDocIdentifiers s ids) = do put_ bh s - put_ bh ids + put_ bh $ BinLocated <$> ids get bh = - liftA2 WithHsDocIdentifiers (get bh) (get bh) + liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh) -- | Extract a mapping from the lexed identifiers to the names they may -- correspond to. diff --git a/compiler/GHC/Hs/DocString.hs b/compiler/GHC/Hs/DocString.hs index 8297d3a2de..c96165d178 100644 --- a/compiler/GHC/Hs/DocString.hs +++ b/compiler/GHC/Hs/DocString.hs @@ -75,19 +75,19 @@ instance Binary HsDocString where MultiLineDocString dec xs -> do putByte bh 0 put_ bh dec - put_ bh xs + put_ bh $ BinLocated <$> xs NestedDocString dec x -> do putByte bh 1 put_ bh dec - put_ bh x + put_ bh $ BinLocated x GeneratedDocString x -> do putByte bh 2 put_ bh x get bh = do tag <- getByte bh case tag of - 0 -> MultiLineDocString <$> get bh <*> get bh - 1 -> NestedDocString <$> get bh <*> get bh + 0 -> MultiLineDocString <$> get bh <*> (fmap unBinLocated <$> get bh) + 1 -> NestedDocString <$> get bh <*> (unBinLocated <$> get bh) 2 -> GeneratedDocString <$> get bh t -> fail $ "HsDocString: invalid tag " ++ show t diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs index 86dc042e63..e492bb726b 100644 --- a/compiler/GHC/Iface/Ext/Binary.hs +++ b/compiler/GHC/Iface/Ext/Binary.hs @@ -339,10 +339,10 @@ fromHieName nc hie_name = do putHieName :: BinHandle -> HieName -> IO () putHieName bh (ExternalName mod occ span) = do putByte bh 0 - put_ bh (mod, occ, span) + put_ bh (mod, occ, BinSrcSpan span) putHieName bh (LocalName occName span) = do putByte bh 1 - put_ bh (occName, span) + put_ bh (occName, BinSrcSpan span) putHieName bh (KnownKeyName uniq) = do putByte bh 2 put_ bh $ unpkUnique uniq @@ -353,10 +353,10 @@ getHieName bh = do case t of 0 -> do (modu, occ, span) <- get bh - return $ ExternalName modu occ span + return $ ExternalName modu occ $ unBinSrcSpan span 1 -> do (occ, span) <- get bh - return $ LocalName occ span + return $ LocalName occ $ unBinSrcSpan span 2 -> do (c,i) <- get bh return $ KnownKeyName $ mkUnique c i diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs index 4aefc4d23c..714b23b7c2 100644 --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -251,12 +251,12 @@ data HieAST a = instance Binary (HieAST TypeIndex) where put_ bh ast = do put_ bh $ sourcedNodeInfo ast - put_ bh $ nodeSpan ast + put_ bh $ BinSpan $ nodeSpan ast put_ bh $ nodeChildren ast get bh = Node <$> get bh - <*> get bh + <*> (unBinSpan <$> get bh) <*> get bh instance Outputable a => Outputable (HieAST a) where @@ -486,19 +486,19 @@ instance Binary ContextInfo where putByte bh 3 put_ bh bt put_ bh sc - put_ bh msp + put_ bh $ BinSpan <$> msp put_ bh (PatternBind a b c) = do putByte bh 4 put_ bh a put_ bh b - put_ bh c + put_ bh $ BinSpan <$> c put_ bh (ClassTyDecl sp) = do putByte bh 5 - put_ bh sp + put_ bh $ BinSpan <$> sp put_ bh (Decl a b) = do putByte bh 6 put_ bh a - put_ bh b + put_ bh $ BinSpan <$> b put_ bh (TyVarBind a b) = do putByte bh 7 put_ bh a @@ -506,13 +506,13 @@ instance Binary ContextInfo where put_ bh (RecField a b) = do putByte bh 8 put_ bh a - put_ bh b + put_ bh $ BinSpan <$> b put_ bh MatchBind = putByte bh 9 put_ bh (EvidenceVarBind a b c) = do putByte bh 10 put_ bh a put_ bh b - put_ bh c + put_ bh $ BinSpan <$> c put_ bh EvidenceVarUse = putByte bh 11 get bh = do @@ -521,14 +521,14 @@ instance Binary ContextInfo where 0 -> return Use 1 -> IEThing <$> get bh 2 -> return TyDecl - 3 -> ValBind <$> get bh <*> get bh <*> get bh - 4 -> PatternBind <$> get bh <*> get bh <*> get bh - 5 -> ClassTyDecl <$> get bh - 6 -> Decl <$> get bh <*> get bh + 3 -> ValBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) + 4 -> PatternBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) + 5 -> ClassTyDecl <$> (fmap unBinSpan <$> get bh) + 6 -> Decl <$> get bh <*> (fmap unBinSpan <$> get bh) 7 -> TyVarBind <$> get bh <*> get bh - 8 -> RecField <$> get bh <*> get bh + 8 -> RecField <$> get bh <*> (fmap unBinSpan <$> get bh) 9 -> return MatchBind - 10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh + 10 -> EvidenceVarBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) 11 -> return EvidenceVarUse _ -> panic "Binary ContextInfo: invalid tag" @@ -679,14 +679,14 @@ instance Binary Scope where put_ bh NoScope = putByte bh 0 put_ bh (LocalScope span) = do putByte bh 1 - put_ bh span + put_ bh $ BinSpan span put_ bh ModuleScope = putByte bh 2 get bh = do (t :: Word8) <- get bh case t of 0 -> return NoScope - 1 -> LocalScope <$> get bh + 1 -> LocalScope . unBinSpan <$> get bh 2 -> return ModuleScope _ -> panic "Binary Scope: invalid tag" @@ -732,13 +732,13 @@ instance Binary TyVarScope where put_ bh (UnresolvedScope ns span) = do putByte bh 1 put_ bh ns - put_ bh span + put_ bh (BinSpan <$> span) get bh = do (t :: Word8) <- get bh case t of 0 -> ResolvedScopes <$> get bh - 1 -> UnresolvedScope <$> get bh <*> get bh + 1 -> UnresolvedScope <$> get bh <*> (fmap unBinSpan <$> get bh) _ -> panic "Binary TyVarScope: invalid tag" -- | `Name`'s get converted into `HieName`'s before being written into @.hie@ diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index 101c14f4ef..ccd5a2210f 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -95,7 +95,6 @@ import GHC.Data.FastString import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Hs.DocString -import GHC.Utils.Binary import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict @@ -1249,17 +1248,6 @@ instance Outputable AnnSortKey where instance Outputable IsUnicodeSyntax where ppr = text . show -instance Binary a => Binary (LocatedL a) where - -- We do not serialise the annotations - put_ bh (L l x) = do - put_ bh (locA l) - put_ bh x - - get bh = do - l <- get bh - x <- get bh - return (L (noAnnSrcSpan l) x) - instance (Outputable a) => Outputable (SrcSpanAnn' a) where ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs index 6dae41ecfc..75f3950208 100644 --- a/compiler/GHC/Unit/Module/Warnings.hs +++ b/compiler/GHC/Unit/Module/Warnings.hs @@ -61,21 +61,21 @@ instance Outputable (WarningTxt pass) where instance Binary (WarningTxt GhcRn) where put_ bh (WarningTxt s w) = do putByte bh 0 - put_ bh s - put_ bh w + put_ bh $ unLoc s + put_ bh $ unLoc <$> w put_ bh (DeprecatedTxt s d) = do putByte bh 1 - put_ bh s - put_ bh d + put_ bh $ unLoc s + put_ bh $ unLoc <$> d get bh = do h <- getByte bh case h of - 0 -> do s <- get bh - w <- get bh + 0 -> do s <- noLoc <$> get bh + w <- fmap noLoc <$> get bh return (WarningTxt s w) - _ -> do s <- get bh - d <- get bh + _ -> do s <- noLoc <$> get bh + d <- fmap noLoc <$> get bh return (DeprecatedTxt s d) diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index f224589ee0..26328d8d05 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -73,6 +73,9 @@ module GHC.Utils.Binary UserData(..), getUserData, setUserData, newReadState, newWriteState, putDictionary, getDictionary, putFS, + + -- * Newtype wrappers + BinSpan(..), BinSrcSpan(..), BinLocated(..) ) where import GHC.Prelude @@ -1285,18 +1288,23 @@ instance Binary ModuleName where -- fs <- get bh -- return (StringLiteral st fs Nothing) -instance Binary a => Binary (Located a) where - put_ bh (L l x) = do - put_ bh l +newtype BinLocated a = BinLocated { unBinLocated :: Located a } + +instance Binary a => Binary (BinLocated a) where + put_ bh (BinLocated (L l x)) = do + put_ bh $ BinSrcSpan l put_ bh x get bh = do - l <- get bh + l <- unBinSrcSpan <$> get bh x <- get bh - return (L l x) + return $ BinLocated (L l x) + +newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan } -instance Binary RealSrcSpan where - put_ bh ss = do +-- See Note [Source Location Wrappers] +instance Binary BinSpan where + put_ bh (BinSpan ss) = do put_ bh (srcSpanFile ss) put_ bh (srcSpanStartLine ss) put_ bh (srcSpanStartCol ss) @@ -1309,8 +1317,8 @@ instance Binary RealSrcSpan where sc <- get bh el <- get bh ec <- get bh - return (mkRealSrcSpan (mkRealSrcLoc f sl sc) - (mkRealSrcLoc f el ec)) + return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) instance Binary UnhelpfulSpanReason where put_ bh r = case r of @@ -1329,24 +1337,44 @@ instance Binary UnhelpfulSpanReason where 3 -> return UnhelpfulGenerated _ -> UnhelpfulOther <$> get bh -instance Binary SrcSpan where - put_ bh (RealSrcSpan ss _sb) = do +newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan } + +-- See Note [Source Location Wrappers] +instance Binary BinSrcSpan where + put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do putByte bh 0 -- BufSpan doesn't ever get serialised because the positions depend -- on build location. - put_ bh ss + put_ bh $ BinSpan ss - put_ bh (UnhelpfulSpan s) = do + put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do putByte bh 1 put_ bh s get bh = do h <- getByte bh case h of - 0 -> do ss <- get bh - return (RealSrcSpan ss Strict.Nothing) + 0 -> do BinSpan ss <- get bh + return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) _ -> do s <- get bh - return (UnhelpfulSpan s) + return $ BinSrcSpan (UnhelpfulSpan s) + + +{- +Note [Source Location Wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Source locations are banned from interface files, to +prevent filepaths affecting interface hashes. + +Unfortunately, we can't remove all binary instances, +as they're used to serialise .hie files, and we don't +want to break binary compatibility. + +To this end, the Bin[Src]Span newtypes wrappers were +introduced to prevent accidentally serialising a +source location as part of a larger structure. +-} -------------------------------------------------------------------------------- -- Instances for the containers package |