[Git][ghc/ghc][wip/no-binary-char] compiler: Remove instance Binary Char
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Tue May 16 09:22:51 UTC 2023
Zubin pushed to branch wip/no-binary-char at Glasgow Haskell Compiler / GHC
Commits:
c36c513a by Zubin Duggal at 2023-05-16T14:52:36+05:30
compiler: Remove instance Binary Char
It is generally not a good idea to serialise strings as [Char] into interface files,
as upon deserialisation each of these would be turned into a highly memory inefficient
structure mostly composed of cons cells and pointers.
If you really want to serialise a Char, use the SerialisableChar newtype.
- - - - -
23 changed files:
- compiler/GHC/Core/Opt/CallerCC.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Fields.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Binary/Typeable.hs
Changes:
=====================================
compiler/GHC/Core/Opt/CallerCC.hs
=====================================
@@ -153,11 +153,11 @@ instance B.Binary NamePattern where
get bh = do
tag <- B.get bh
case tag :: Word8 of
- 0 -> PChar <$> B.get bh <*> B.get bh
+ 0 -> PChar <$> (B.getSerialisedChar <$> B.get bh) <*> B.get bh
1 -> PWildcard <$> B.get bh
2 -> pure PEnd
_ -> panic "Binary(NamePattern): Invalid tag"
- put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y
+ put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh (B.SerialisableChar x) >> B.put_ bh y
put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x
put_ bh PEnd = B.put_ bh (2 :: Word8)
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -320,7 +320,7 @@ toIfaceCoercionX fr co
go_prov :: UnivCoProvenance -> IfaceUnivCoProv
go_prov (PhantomProv co) = IfacePhantomProv (go co)
go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
- go_prov (PluginProv str) = IfacePluginProv str
+ go_prov (PluginProv str) = IfacePluginProv (mkFastString str)
go_prov (CorePrepProv b) = IfaceCorePrepProv b
toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -290,7 +290,7 @@ instance Ord NonDetFastString where
-- representation). Hence it is deterministic from one run to the other.
newtype LexicalFastString
= LexicalFastString FastString
- deriving newtype (Eq, Show)
+ deriving newtype (Eq, Show, NFData)
deriving stock Data
instance Ord LexicalFastString where
=====================================
compiler/GHC/Hs/Doc.hs
=====================================
@@ -28,6 +28,7 @@ module GHC.Hs.Doc
import GHC.Prelude
+import GHC.Data.FastString
import GHC.Utils.Binary
import GHC.Types.Name
import GHC.Utils.Outputable as Outputable hiding ((<>))
@@ -40,10 +41,9 @@ import GHC.Driver.Flags
import Control.DeepSeq
import Data.Data
+import Data.Function (on)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
-import Data.Map (Map)
-import qualified Data.Map as Map
import Data.List.NonEmpty (NonEmpty(..))
import GHC.LanguageExtensions.Type
import qualified GHC.Utils.Outputable as O
@@ -123,7 +123,7 @@ type LHsDoc pass = Located (HsDoc pass)
data DocStructureItem
= DsiSectionHeading !Int !(HsDoc GhcRn)
| DsiDocChunk !(HsDoc GhcRn)
- | DsiNamedChunkRef !(String)
+ | DsiNamedChunkRef !FastString
| DsiExports !Avails
| DsiModExport
!(NonEmpty ModuleName) -- ^ We might re-export avails from multiple
@@ -176,7 +176,7 @@ instance Outputable DocStructureItem where
, nest 2 (pprHsDocDebug doc)
]
DsiNamedChunkRef name ->
- text "reference to named chunk:" <+> text name
+ text "reference to named chunk:" <+> ftext name
DsiExports avails ->
text "avails:" $$ nest 2 (ppr avails)
DsiModExport mod_names avails ->
@@ -202,12 +202,12 @@ data Docs = Docs
, docs_args :: UniqMap Name (IntMap (HsDoc GhcRn))
-- ^ Docs for arguments. E.g. function arguments, method arguments.
, docs_structure :: DocStructure
- , docs_named_chunks :: Map String (HsDoc GhcRn)
+ , docs_named_chunks :: UniqMap FastString (HsDoc GhcRn)
-- ^ Map from chunk name to content.
--
-- This map will be empty unless we have an explicit export list from which
-- we can reference the chunks.
- , docs_haddock_opts :: Maybe String
+ , docs_haddock_opts :: Maybe FastString
-- ^ Haddock options from @OPTIONS_HADDOCK@ or from @-haddock-opts at .
, docs_language :: Maybe Language
-- ^ The 'Language' used in the module, for example 'Haskell2010'.
@@ -227,7 +227,7 @@ instance Binary Docs where
put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_decls docs)
put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_args docs)
put_ bh (docs_structure docs)
- put_ bh (Map.toList $ docs_named_chunks docs)
+ put_ bh (sortBy (lexicalCompareFS `on` fst) $ nonDetUniqMapToList $ docs_named_chunks docs)
put_ bh (docs_haddock_opts docs)
put_ bh (docs_language docs)
put_ bh (docs_extensions docs)
@@ -236,7 +236,7 @@ instance Binary Docs where
decls <- listToUniqMap <$> get bh
args <- listToUniqMap <$> get bh
structure <- get bh
- named_chunks <- Map.fromList <$> get bh
+ named_chunks <- listToUniqMap <$> get bh
haddock_opts <- get bh
language <- get bh
exts <- get bh
@@ -257,7 +257,7 @@ instance Outputable Docs where
, pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls
, pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args
, pprField (vcat . map ppr) "documentation structure" docs_structure
- , pprField (pprMap (doubleQuotes . text) pprHsDocDebug) "named chunks"
+ , pprField (ppr . fmap (ppr . pprHsDocDebug)) "named chunks"
docs_named_chunks
, pprField pprMbString "haddock options" docs_haddock_opts
, pprField ppr "language" docs_language
@@ -268,14 +268,11 @@ instance Outputable Docs where
pprField :: (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField ppr' heading lbl =
text heading O.<> colon $$ nest 2 (ppr' (lbl docs))
- pprMap pprKey pprVal m =
- vcat $ flip map (Map.toList m) $ \(k, v) ->
- pprKey k O.<> colon $$ nest 2 (pprVal v)
pprIntMap pprKey pprVal m =
vcat $ flip map (IntMap.toList m) $ \(k, v) ->
pprKey k O.<> colon $$ nest 2 (pprVal v)
pprMbString Nothing = empty
- pprMbString (Just s) = text s
+ pprMbString (Just s) = ftext s
pprMaybe ppr' = \case
Nothing -> text "Nothing"
Just x -> text "Just" <+> ppr' x
@@ -286,7 +283,7 @@ emptyDocs = Docs
, docs_decls = emptyUniqMap
, docs_args = emptyUniqMap
, docs_structure = []
- , docs_named_chunks = Map.empty
+ , docs_named_chunks = emptyUniqMap
, docs_haddock_opts = Nothing
, docs_language = Nothing
, docs_extensions = EnumSet.empty
=====================================
compiler/GHC/Hs/DocString.hs
=====================================
@@ -25,6 +25,7 @@ module GHC.Hs.DocString
import GHC.Prelude
+import GHC.Data.FastString
import GHC.Utils.Binary
import GHC.Utils.Encoding
import GHC.Utils.Outputable as Outputable hiding ((<>))
@@ -102,7 +103,7 @@ instance Binary HsDocString where
data HsDocStringDecorator
= HsDocStringNext -- ^ '|' is the decorator
| HsDocStringPrevious -- ^ '^' is the decorator
- | HsDocStringNamed !String -- ^ '$<string>' is the decorator
+ | HsDocStringNamed !LexicalFastString -- ^ '$<string>' is the decorator
| HsDocStringGroup !Int -- ^ The decorator is the given number of '*'s
deriving (Eq, Ord, Show, Data)
@@ -118,7 +119,7 @@ instance NFData HsDocStringDecorator where
printDecorator :: HsDocStringDecorator -> String
printDecorator HsDocStringNext = "|"
printDecorator HsDocStringPrevious = "^"
-printDecorator (HsDocStringNamed n) = '$':n
+printDecorator (HsDocStringNamed (LexicalFastString n)) = '$':unpackFS n
printDecorator (HsDocStringGroup n) = replicate n '*'
instance Binary HsDocStringDecorator where
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -12,6 +12,7 @@ module GHC.HsToCore.Docs where
import GHC.Prelude
import GHC.Data.Bag
+import GHC.Data.FastString
import GHC.Hs.Binds
import GHC.Hs.Doc
import GHC.Hs.Decls
@@ -86,7 +87,7 @@ extractDocs dflags
, docs_args = th_arg_docs `unionArgMaps` arg_map
, docs_structure = doc_structure
, docs_named_chunks = named_chunks
- , docs_haddock_opts = haddockOptions dflags
+ , docs_haddock_opts = fmap mkFastString $ haddockOptions dflags
, docs_language = language_
, docs_extensions = exts
}
@@ -146,7 +147,7 @@ mkDocStructureFromExportList mdl import_avails export_list =
(IEModuleContents _ lmn, avails) -> moduleExport (unLoc lmn) avails
(IEGroup _ level doc, _) -> DsiSectionHeading level (unLoc doc)
(IEDoc _ doc, _) -> DsiDocChunk (unLoc doc)
- (IEDocNamed _ name, _) -> DsiNamedChunkRef name
+ (IEDocNamed _ name, _) -> DsiNamedChunkRef (mkFastString name)
(_, avails) -> DsiExports (nubAvails avails)
moduleExport :: ModuleName -- Alias
@@ -220,12 +221,12 @@ mkDocStructureFromDecls env all_exports decls =
-- since there would be no way to link to a named chunk.
getNamedChunks :: Bool -- ^ Do we have an explicit export list?
-> HsGroup (GhcPass pass)
- -> Map String (HsDoc (GhcPass pass))
+ -> UniqMap FastString (HsDoc (GhcPass pass))
getNamedChunks True decls =
- M.fromList $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case
- DocCommentNamed name doc -> Just (name, unLoc doc)
+ listToUniqMap $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case
+ DocCommentNamed name doc -> Just (mkFastString name, unLoc doc)
_ -> Nothing
-getNamedChunks False _ = M.empty
+getNamedChunks False _ = emptyUniqMap
-- | Create decl and arg doc-maps by looping through the declarations.
-- For each declaration, find its names, its subordinates, and its doc strings.
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -173,7 +173,7 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
where
linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls
- msg m = moduleNameString (moduleName m) ++ "[TH] changed"
+ msg m = moduleNameFS (moduleName m) `appendFS` fsLit "[TH] changed"
fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg
=====================================
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)
=====================================
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'
=====================================
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"
=====================================
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
=====================================
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
=====================================
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"
=====================================
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
=====================================
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 at 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 at 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
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -401,7 +401,7 @@ data IfaceCoercion
data IfaceUnivCoProv
= IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
- | IfacePluginProv String
+ | IfacePluginProv FastString
| IfaceCorePrepProv Bool -- See defn of CorePrepProv
{- Note [Holes in IfaceCoercion]
@@ -1859,7 +1859,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"
@@ -1925,7 +1925,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
@@ -1935,7 +1935,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
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1519,7 +1519,7 @@ tcIfaceCo = go
tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
-tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
+tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv (unpackFS str)
tcIfaceUnivCoProv (IfaceCorePrepProv b) = return $ CorePrepProv b
{-
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -1517,7 +1517,7 @@ mkHdkCommentPrev loc mkDS = (HdkCommentPrev ds,ITdocComment ds loc)
mkHdkCommentNamed :: PsSpan -> String -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)
mkHdkCommentNamed loc name mkDS = (HdkCommentNamed name ds, ITdocComment ds loc)
- where ds = mkDS (HsDocStringNamed name)
+ where ds = mkDS (HsDocStringNamed $ LexicalFastString $ mkFastString name)
mkHdkCommentSection :: PsSpan -> Int -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)
mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc)
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -227,12 +227,12 @@ putObject
-> IO ()
putObject bh mod_name deps os = do
forM_ magic (putByte bh . fromIntegral . ord)
- put_ bh (show hiVersion)
+ put_ bh (map SerialisableChar $ show hiVersion)
-- we store the module name as a String because we don't want to have to
-- decode the FastString table just to decode it when we're looking for an
-- object in an archive.
- put_ bh (moduleNameString mod_name)
+ put_ bh (moduleNameFS mod_name)
(bh_fs, _bin_dict, put_dict) <- initFSTable bh
@@ -281,12 +281,12 @@ getObjectHeader bh = do
case is_magic of
False -> pure (Left "invalid magic header")
True -> do
- is_correct_version <- ((== hiVersion) . read) <$> get bh
+ is_correct_version <- ((== hiVersion) . read . map getSerialisedChar) <$> get bh
case is_correct_version of
False -> pure (Left "invalid header version")
True -> do
mod_name <- get bh
- pure (Right (mkModuleName (mod_name)))
+ pure (Right (mkModuleNameFS mod_name))
-- | Parse object body. Must be called after a sucessful getObjectHeader
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -254,7 +254,7 @@ for more details.
-}
instance Binary Literal where
- put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
+ put_ bh (LitChar aa) = do putByte bh 0; put_ bh $ SerialisableChar aa
put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
put_ bh (LitNullAddr) = putByte bh 2
put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah
@@ -276,7 +276,7 @@ instance Binary Literal where
case h of
0 -> do
aa <- get bh
- return (LitChar aa)
+ return (LitChar $ getSerialisedChar aa)
1 -> do
ab <- get bh
return (LitString ab)
=====================================
compiler/GHC/Unit/Module/Deps.hs
=====================================
@@ -283,7 +283,7 @@ data Usage
usg_file_hash :: Fingerprint,
-- ^ 'Fingerprint' of the file contents.
- usg_file_label :: Maybe String
+ usg_file_label :: Maybe FastString
-- ^ An optional string which is used in recompilation messages if
-- file in question has changed.
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -1,5 +1,7 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -81,7 +83,7 @@ module GHC.Utils.Binary
FSTable, initFSTable, getDictFastString, putDictFastString,
-- * Newtype wrappers
- BinSpan(..), BinSrcSpan(..), BinLocated(..)
+ BinSpan(..), BinSrcSpan(..), BinLocated(..), SerialisableChar(..)
) where
import GHC.Prelude
@@ -125,6 +127,8 @@ import qualified Data.IntMap as IntMap
import GHC.ForeignPtr ( unsafeWithForeignPtr )
#endif
+import GHC.TypeError
+
type BinArray = ForeignPtr Word8
#if !MIN_VERSION_base(4,15,0)
@@ -675,9 +679,20 @@ instance Binary Bool where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
-instance Binary Char where
- put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
- get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+instance (TypeError (Text "No instance for Binary Char"
+ :$$: Text "We don't want to serialise Strings into interface files"
+ :$$: Text "Use a compact representation like " :<>: ShowType FastString :<>: Text " instead"
+ :$$: Text "If you really want to serialise you can use " :<>: ShowType SerialisableChar)
+ )
+ => Binary Char where
+ put_ = undefined
+ get = undefined
+
+newtype SerialisableChar = SerialisableChar { getSerialisedChar :: Char }
+
+instance Binary SerialisableChar where
+ put_ bh (SerialisableChar c) = put_ bh (fromIntegral (ord c) :: Word32)
+ get bh = do x <- get bh; return $! (SerialisableChar $ chr (fromIntegral (x :: Word32)))
instance Binary Int where
put_ bh i = put_ bh (fromIntegral i :: Int64)
=====================================
compiler/GHC/Utils/Binary/Typeable.hs
=====================================
@@ -17,6 +17,7 @@ where
import GHC.Prelude
import GHC.Utils.Binary
+import GHC.Data.FastString
import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))
#if __GLASGOW_HASKELL__ >= 901
@@ -32,13 +33,13 @@ import Data.Kind (Type)
instance Binary TyCon where
put_ bh tc = do
- put_ bh (tyConPackage tc)
- put_ bh (tyConModule tc)
- put_ bh (tyConName tc)
+ put_ bh (mkFastString $ tyConPackage tc)
+ put_ bh (mkFastString $ tyConModule tc)
+ put_ bh (mkFastString $ tyConName tc)
put_ bh (tyConKindArgs tc)
put_ bh (tyConKindRep tc)
get bh =
- mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+ mkTyCon <$> (unpackFS <$> get bh) <*> (unpackFS <$> get bh) <*> (unpackFS <$> get bh) <*> get bh <*> get bh
getSomeTypeRep :: BinHandle -> IO SomeTypeRep
getSomeTypeRep bh = do
@@ -157,7 +158,7 @@ instance Binary KindRep where
put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b
put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b
put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r
- put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r
+ put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh (mkFastString r)
get bh = do
tag <- getByte bh
@@ -167,7 +168,7 @@ instance Binary KindRep where
2 -> KindRepApp <$> get bh <*> get bh
3 -> KindRepFun <$> get bh <*> get bh
4 -> KindRepTYPE <$> get bh
- 5 -> KindRepTypeLit <$> get bh <*> get bh
+ 5 -> KindRepTypeLit <$> get bh <*> (unpackFS <$> get bh)
_ -> fail "Binary.putKindRep: invalid tag"
instance Binary TypeLitSort where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c36c513a9ea619ad7cb0f1c8f22de0407178affe
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c36c513a9ea619ad7cb0f1c8f22de0407178affe
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230516/324bc73a/attachment-0001.html>
More information about the ghc-commits
mailing list