diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2025 Simon Hengel + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/ghc-hie.cabal b/ghc-hie.cabal new file mode 100644 --- /dev/null +++ b/ghc-hie.cabal @@ -0,0 +1,89 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: ghc-hie +version: 0.0.0 +synopsis: HIE-file parsing machinery that supports multiple versions of GHC +category: Development +homepage: https://github.com/sol/ghc-hie#readme +bug-reports: https://github.com/sol/ghc-hie/issues +author: Simon Hengel +maintainer: Simon Hengel +copyright: (c) 2025 Simon Hengel +license: MIT +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/sol/ghc-hie + +library + exposed-modules: + GHC.Iface.Ext.Binary + GHC.Iface.Ext.Debug + GHC.Iface.Ext.Types + GHC.Iface.Ext.Utils + other-modules: + GHC.Iface.Ext.Binary.GHC912 + GHC.Iface.Ext.Binary.Header + GHC.Iface.Ext.Binary.Instances + GHC.Iface.Ext.Binary.Utils + GHC.Iface.Ext.Compat + hs-source-dirs: + src + ghc-options: -Wall -O2 + build-depends: + array + , base ==4.* + , bytestring + , containers + , deepseq + , directory + , filepath + , ghc ==9.10.1 || ==9.10.2 || ==9.12.1 || ==9.12.2 + , ghc-boot + , transformers + default-language: GHC2021 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + GHC.Iface.Ext.Binary + GHC.Iface.Ext.Binary.GHC912 + GHC.Iface.Ext.Binary.Header + GHC.Iface.Ext.Binary.Instances + GHC.Iface.Ext.Binary.Utils + GHC.Iface.Ext.Compat + GHC.Iface.Ext.Debug + GHC.Iface.Ext.Types + GHC.Iface.Ext.Utils + GHC.Iface.Ext.BinarySpec + GHC.Iface.Ext.Upstream + SmokeSpec + hs-source-dirs: + src + test + ghc-options: -Wall -O2 + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + QuickCheck + , array + , base ==4.* + , bytestring + , containers + , deepseq + , directory + , filepath + , ghc ==9.10.1 || ==9.10.2 || ==9.12.1 || ==9.12.2 + , ghc-boot + , hspec ==2.* + , process + , temporary + , transformers + default-language: GHC2021 diff --git a/src/GHC/Iface/Ext/Binary.hs b/src/GHC/Iface/Ext/Binary.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Iface/Ext/Binary.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiWayIf #-} +module GHC.Iface.Ext.Binary ( + readHieFile +, readHieFileEither +, HieHeader +, HieFileResult(..) +, extractSourceFileName +) where + +import Data.List (intercalate) +import Data.ByteString (ByteString) + +import GHC.Types.Name.Cache + +import GHC.Iface.Ext.Types + +import GHC.Iface.Ext.Binary.Utils +import GHC.Iface.Ext.Binary.GHC912 qualified as HieFile +import GHC.Iface.Ext.Binary.Header (HieHeader, readHieFileHeader) +import GHC.Iface.Ext.Binary.Header qualified as Header + +supported :: [Integer] +supported = supported910 ++ supported912 + +supported910 :: [Integer] +supported910 = [9081 .. 9084] ++ [9101 .. 9102] + +supported912 :: [Integer] +supported912 = [9121 .. 9122] + +-- | Read a `HieFile` from a `FilePath`. Can use an existing `NameCache`. +readHieFile :: NameCache -> FilePath -> IO HieFileResult +readHieFile name_cache file = readHie (unsupportedVersion file) id name_cache file + +extractSourceFileName :: FilePath -> IO FilePath +extractSourceFileName file = readBinMem file >>= Header.extractSourceFileName + +unsupportedVersion :: FilePath -> HieHeader -> IO a +unsupportedVersion file = fail . unsupportedVersionError file + +unsupportedVersionError :: FilePath -> HieHeader -> String +unsupportedVersionError file (show -> version, _) = + "Unsupported HIE version " <> version <> " for file " <> file <> ", supported versions: " <> supportedVersions + where + supportedVersions :: String + supportedVersions = intercalate ", " . reverse $ map show supported + +-- | Read a `HieFile` from a `FilePath`. Can use an existing `NameCache`. +-- `Left` case returns the failing header versions. +readHieFileEither :: NameCache -> FilePath -> IO (Either HieHeader HieFileResult) +readHieFileEither = readHie (return . Left) Right + +readHie :: (HieHeader -> IO a) -> (HieFileResult -> a) -> NameCache -> FilePath -> IO a +readHie left right name_cache file = do + bh0 <- readBinMem file + header@(version, ghcVersion) <- readHieFileHeader file bh0 + let hieFileResult = right . HieFileResult version ghcVersion + if + | version `elem` supported910 -> hieFileResult <$> HieFile.readHieFile910 bh0 name_cache + | version `elem` supported912 -> hieFileResult <$> HieFile.readHieFile912 bh0 name_cache + | otherwise -> left header +{-# INLINE readHie #-} + +data HieFileResult = HieFileResult { + hie_file_result_version :: Integer +, hie_file_result_ghc_version :: ByteString +, hie_file_result :: HieFile +} diff --git a/src/GHC/Iface/Ext/Binary/GHC912.hs b/src/GHC/Iface/Ext/Binary/GHC912.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Iface/Ext/Binary/GHC912.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE BlockArguments #-} +module GHC.Iface.Ext.Binary.GHC912 ( + readHieFile910 +, readHieFile912 +) where + +import Data.Typeable +import Prelude hiding (span, mod) + +import GHC.Builtin.Utils +import GHC.Iface.Ext.Binary.Utils +import GHC.Iface.Ext.Types +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Types.Unique +import GHC.Utils.Outputable hiding (char) +import GHC.Utils.Panic +import GHC.Types.Avail (AvailInfo) +import GHC.Unit.Module (Module) +import GHC.Types.SrcLoc + +import Data.Array (Array) +import qualified Data.Array as A +import qualified Data.Array.IO as A +import qualified Data.Array.Unsafe as A +import Data.Word ( Word32 ) +import Data.ByteString (ByteString) +import Control.Monad + +readHieFile910 :: ReadBinHandle -> NameCache -> IO HieFile +readHieFile910 bh0 name_cache = do + dict_p <- get bh0 + symtab_p <- get bh0 + readHieFile dict_p symtab_p (const mempty) bh0 name_cache + +readHieFile912 :: ReadBinHandle -> NameCache -> IO HieFile +readHieFile912 bh0 name_cache = do + dict_p <- makeAbsoluteBin <$> getRelBin bh0 + symtab_p <- makeAbsoluteBin <$> getRelBin bh0 + readHieFile dict_p symtab_p get bh0 name_cache + +initReadNameTable :: Module -> NameCache -> IO (ReaderTable Name) +initReadNameTable currentModule cache = do + return $ + ReaderTable + { getTable = \bh -> getSymbolTable currentModule bh cache + , mkReaderFromTable = \tbl -> mkReader (getSymTabName tbl) + } + +readHieFile :: Bin () -> Bin () -> (ReadBinHandle -> IO NameEntityInfo) -> ReadBinHandle -> NameCache -> IO HieFile +readHieFile dict_p symtab_p getNameEntityInfo bh0 name_cache = do + + fsReaderTable <- initFastStringReaderTable + bh_dict <- get_dictionary dict_p fsReaderTable bh0 + + file <- get @FilePath bh_dict + currentModule <- get @Module bh_dict + + nameReaderTable <- initReadNameTable currentModule name_cache + bh_symtab <- get_dictionary symtab_p nameReaderTable bh_dict + + -- load the actual data + HieFile file currentModule + <$> get @(Array TypeIndex HieTypeFlat) bh_symtab + <*> get @(HieASTs TypeIndex) bh_symtab + <*> get @([AvailInfo]) bh_symtab + <*> get @ByteString bh_symtab + <*> getNameEntityInfo bh_symtab + where + get_dictionary :: forall a. Typeable a => Bin () -> ReaderTable a -> ReadBinHandle -> IO ReadBinHandle + get_dictionary p tbl bin_handle = withRestore do + seekBinReader bin_handle p + fsTable :: SymbolTable a <- getTable tbl bin_handle + let + fsReader :: BinaryReader a + fsReader = mkReaderFromTable tbl fsTable + + bhFs :: ReadBinHandle + bhFs = addReaderToUserData fsReader bin_handle + pure bhFs + + withRestore :: IO a -> IO a + withRestore action = do + backup <- tellBinReader bh0 + action <* seekBinReader bh0 backup + +getSymbolTable :: Module -> ReadBinHandle -> NameCache -> IO (SymbolTable Name) +getSymbolTable currentModule bh name_cache = do + sz <- get bh + mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name) + forM_ [0..(sz-1)] $ \i -> do + od_name <- getHieName bh + name <- fromHieName currentModule name_cache od_name + A.writeArray mut_arr i name + A.unsafeFreeze mut_arr + +getSymTabName :: SymbolTable Name -> ReadBinHandle -> IO Name +getSymTabName st bh = do + i :: Word32 <- get bh + return $ st A.! (fromIntegral i) + +-- ** Converting to and from `HieName`'s + +fromHieName :: Module -> NameCache -> HieName -> IO Name +fromHieName currentModule nc hie_name = do + + case hie_name of + ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do + case lookupOrigNameCache cache mod occ of + Just old_name -> case nameSrcSpan old_name of + UnhelpfulSpan {} -> update + RealSrcSpan {} + | mod == currentModule -> update + | otherwise -> keep + where + new_name = mkExternalName uniq mod occ span + new_cache = extendOrigNameCache cache mod occ new_name + uniq = nameUnique old_name + + update = pure (new_cache, new_name) + keep = pure (cache, old_name) + + Nothing -> do + uniq <- takeUniqFromNameCache nc + let name = mkExternalName uniq mod occ span + new_cache = extendOrigNameCache cache mod occ name + pure (new_cache, name) + + LocalName occ span -> do + uniq <- takeUniqFromNameCache nc + -- don't update the NameCache for local names + pure $ mkInternalName uniq occ span + + KnownKeyName u -> case lookupKnownKeyName u of + Nothing -> pprPanic "fromHieName:unknown known-key unique" + (ppr u) + Just n -> pure n + +-- ** Reading and writing `HieName`'s + +getHieName :: ReadBinHandle -> IO HieName +getHieName bh = do + t <- getByte bh + case t of + 0 -> do + (modu, occ, span) <- get bh + return $ ExternalName modu occ $ unBinSrcSpan span + 1 -> do + (occ, span) <- get bh + return $ LocalName occ $ unBinSrcSpan span + 2 -> do + (c,i) <- get bh + return $ KnownKeyName $ mkUnique c i + _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag" diff --git a/src/GHC/Iface/Ext/Binary/Header.hs b/src/GHC/Iface/Ext/Binary/Header.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Iface/Ext/Binary/Header.hs @@ -0,0 +1,67 @@ +module GHC.Iface.Ext.Binary.Header ( + extractSourceFileName +, HieHeader +, readHieFileHeader +) where + +import Control.Monad +import Data.Word +import Data.ByteString (ByteString, pack) +import Data.ByteString.Internal (w2c) +import GHC.Settings.Utils (maybeRead) + +import GHC.Iface.Ext.Binary.Utils + +hieMagic :: [Word8] +hieMagic = [72,73,69] + +hieMagicLen :: Int +hieMagicLen = 3 + +newline :: Word8 +newline = 10 + +extractSourceFileName :: ReadBinHandle -> IO FilePath +extractSourceFileName bh0 = do + advance bh0 hieMagicLen + skipLine + skipLine + advance bh0 8 + get @FilePath bh0 + where + skipLine :: IO () + skipLine = do + c <- get @Word8 bh0 + if c == newline + then return () + else skipLine + +type HieHeader = (Integer, ByteString) + +readHieFileHeader :: FilePath -> ReadBinHandle -> IO HieHeader +readHieFileHeader file bh0 = do + magic <- replicateM hieMagicLen (get bh0) + version <- map w2c <$> takeLine + case maybeRead version of + Nothing -> do + fail $ "readHieFileHeader: hieVersion isn't an Integer: " <> show version + Just hieVersion -> do + ghcVersion <- pack <$> takeLine + when (magic /= hieMagic) . fail $ unwords [ + "readHieFileHeader: headers don't match for file:" + , file + , "Expected" + , show hieMagic + , "but got", show magic + ] + return (hieVersion, ghcVersion) + where + takeLine :: IO [Word8] + takeLine = reverse <$> loop [] + where + loop :: [Word8] -> IO [Word8] + loop acc = do + c <- get @Word8 bh0 + if c == newline + then return acc + else loop (c : acc) diff --git a/src/GHC/Iface/Ext/Binary/Instances.hs b/src/GHC/Iface/Ext/Binary/Instances.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Iface/Ext/Binary/Instances.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module GHC.Iface.Ext.Binary.Instances where + +import GHC.Types.Unique (getUnique) +import GHC.Types.Unique.DSet (unionManyUniqDSets) +import Control.Monad +import Data.Proxy +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Types.Basic +import GHC.Types.Var hiding (varName) +import GHC.Unit.Types +import GHC.Iface.Type + +import GHC.Iface.Ext.Binary.Utils + +import GHC.Utils.Panic.Plain (panic) + +instance Binary Name where + put_ bh name = + case findUserDataWriter Proxy bh of + tbl -> putEntry tbl bh name + + get bh = + case findUserDataReader Proxy bh of + tbl -> getEntry tbl bh + +instance Binary a => Binary (GenModule a) where + put_ bh (Module p n) = put_ bh p >> put_ bh n + -- Module has strict fields, so use $! in order not to allocate a thunk + get bh = do p <- get bh; n <- get bh; return $! Module p n + +instance Binary Unit where + put_ bh (RealUnit def_uid) = do + putByte bh 0 + put_ bh def_uid + put_ bh (VirtUnit indef_uid) = do + putByte bh 1 + put_ bh indef_uid + put_ bh HoleUnit = + putByte bh 2 + get bh = do b <- getByte bh + u <- case b of + 0 -> fmap RealUnit (get bh) + 1 -> fmap VirtUnit (get bh) + _ -> pure HoleUnit + -- Unit has strict fields that need forcing; otherwise we allocate a thunk. + pure $! u + +deriving newtype instance Binary unit => Binary (Definite unit) + +instance Binary InstantiatedUnit where + put_ bh indef = do + put_ bh (instUnitInstanceOf indef) + put_ bh (instUnitInsts indef) + get bh = do + cid <- get bh + insts <- get bh + let fs = mkInstantiatedUnitHash cid insts + -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk + return $! InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs + } + +instance Binary UnitId where + put_ bh (UnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (UnitId fs) + +instance Binary AvailInfo where + put_ bh (Avail aa) = do + putByte bh 0 + put_ bh aa + put_ bh (AvailTC ab ac) = do + putByte bh 1 + put_ bh ab + put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Avail aa) + _ -> do ab <- get bh + ac <- get bh + return (AvailTC ab ac) + +instance Binary IfaceTyCon where + put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i + + get bh = do + n <- get bh + i <- get bh + return (IfaceTyCon n i) + +instance Binary IfaceTyConSort where + put_ bh IfaceNormalTyCon = putByte bh 0 + put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort + put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity + put_ bh IfaceEqualityTyCon = putByte bh 3 + + get bh = do + n <- getByte bh + case n of + 0 -> return IfaceNormalTyCon + 1 -> IfaceTupleTyCon <$> get bh <*> get bh + 2 -> IfaceSumTyCon <$> get bh + _ -> return IfaceEqualityTyCon + +instance Binary IfaceTyConInfo where + put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s + + get bh = mkIfaceTyConInfo <$!> get bh <*> get bh + -- We want to make sure, when reading from disk, as the most common case + -- is supposed to be shared. Any thunk adds an additional indirection + -- making sharing less useful. + -- + -- See !12200 for how this bang and the one in 'IfaceTyCon' reduces the + -- residency by ~10% when loading 'mi_extra_decls' from disk. + +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh ConstraintTuple = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return BoxedTuple + 1 -> return UnboxedTuple + _ -> return ConstraintTuple + +instance Binary PromotionFlag where + put_ bh NotPromoted = putByte bh 0 + put_ bh IsPromoted = putByte bh 1 + + get bh = do + n <- getByte bh + case n of + 0 -> return NotPromoted + 1 -> return IsPromoted + _ -> fail "Binary(IsPromoted): fail)" + +instance Binary ForAllTyFlag where + put_ bh Required = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Inferred = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Required + 1 -> return Specified + _ -> return Inferred + +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 + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + 3 -> do { n <- get bh + ; return (IfaceCharTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + +putAllTables :: WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b) +putAllTables _ [] act = do + a <- act + pure ([], a) +putAllTables bh (x : xs) act = do + (r, (res, a)) <- forwardPutRel bh (const $ putTable x bh) $ do + putAllTables bh xs act + pure (r : res, a) + +instance Binary OccName where + put_ bh name = do + put_ bh (occNameSpace name) + put_ bh (occNameFS name) + get bh = do + aa <- get bh + ab <- get bh + return (mkOccNameFS aa ab) + +instance Binary NameSpace where + put_ _ _ = undefined + get bh = do + h <- getByte bh + case h of + 0 -> return varName + 1 -> return dataName + 2 -> return tvName + 3 -> return tcClsName + _ -> do + parent <- get bh + return $ fieldName parent diff --git a/src/GHC/Iface/Ext/Binary/Utils.hs b/src/GHC/Iface/Ext/Binary/Utils.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Iface/Ext/Binary/Utils.hs @@ -0,0 +1,2092 @@ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UnboxedTuples #-} + +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +{-# OPTIONS_GHC -w #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +module GHC.Iface.Ext.Binary.Utils + ( {-type-} Bin, RelBin(..), getRelBin, + {-class-} Binary(..), + {-type-} ReadBinHandle, WriteBinHandle, + SymbolTable, Dictionary, + + BinData(..), dataHandle, handleData, + unsafeUnpackBinBuffer, + + openBinMem, +-- closeBin, + + advance, + + seekBinWriter, + seekBinReader, + seekBinReaderRel, + tellBinReader, + tellBinWriter, + castBin, + withBinBuffer, + freezeWriteHandle, + shrinkBinBuffer, + thawReadHandle, + + foldGet, foldGet', + + writeBinMem, + readBinMem, + readBinMemN, + + putAt, getAt, + putAtRel, + forwardPut, forwardPut_, forwardGet, + forwardPutRel, forwardPutRel_, forwardGetRel, + + -- * For writing instances + putByte, + getByte, + putByteString, + getByteString, + + -- * Variable length encodings + putULEB128, + getULEB128, + putSLEB128, + getSLEB128, + + -- * Fixed length encoding + FixedLengthEncoding(..), + + -- * Lazy Binary I/O + lazyGet, + lazyPut, + lazyGet', + lazyPut', + lazyGetMaybe, + lazyPutMaybe, + + -- * User data + ReaderUserData, getReaderUserData, setReaderUserData, noReaderUserData, + WriterUserData, getWriterUserData, setWriterUserData, noWriterUserData, + mkWriterUserData, mkReaderUserData, + newReadState, newWriteState, + addReaderToUserData, addWriterToUserData, + findUserDataReader, findUserDataWriter, + -- * Binary Readers & Writers + BinaryReader(..), BinaryWriter(..), + mkWriter, mkReader, + SomeBinaryReader, SomeBinaryWriter, + mkSomeBinaryReader, mkSomeBinaryWriter, + -- * Tables + ReaderTable(..), + WriterTable(..), + -- * String table ("dictionary") + initFastStringReaderTable, initFastStringWriterTable, + putDictionary, getDictionary, putFS, + FSTable(..), getDictFastString, putDictFastString, + -- * Generic deduplication table + GenericSymbolTable(..), + initGenericSymbolTable, + getGenericSymtab, putGenericSymTab, + getGenericSymbolTable, putGenericSymbolTable, + -- * Newtype wrappers + BinSpan(..), BinSrcSpan(..), BinLocated(..), + -- * Newtypes for types that have canonically more than one valid encoding + BindingName(..), + simpleBindingNameWriter, + simpleBindingNameReader, + FullBinData(..), freezeBinHandle, thawBinHandle, putFullBinData, + BinArray, + + makeAbsoluteBin, + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Module.Name (ModuleName(..)) + +import GHC.Types.Name (Name) +import GHC.Data.FastString +import GHC.Data.TrieMap +import GHC.Utils.Panic.Plain +import GHC.Types.Unique.FM +import GHC.Data.FastMutInt +import GHC.Utils.Fingerprint +import GHC.Types.SrcLoc +import GHC.Types.Unique +import qualified GHC.Data.Strict as Strict +import GHC.Utils.Outputable( JoinPointHood(..) ) + +import Control.DeepSeq +import Control.Monad ( when, (<$!>), unless, forM_, void ) +import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) +import Data.Array +import Data.Array.IO +import Data.Array.Unsafe +import Data.ByteString (ByteString, copy) +import Data.Coerce +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Data.IORef +import Data.Char ( ord, chr ) +import Data.List.NonEmpty ( NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy +import Data.Set ( Set ) +import qualified Data.Set as Set +import Data.List (unfoldr) +import System.IO as IO +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +import Type.Reflection ( Typeable, SomeTypeRep(..) ) +import qualified Type.Reflection as Refl +import GHC.Real ( Ratio(..) ) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +#if MIN_VERSION_base(4,15,0) +import GHC.ForeignPtr ( unsafeWithForeignPtr ) +#endif + +import Unsafe.Coerce (unsafeCoerce) + +type BinArray = ForeignPtr Word8 + +#if !MIN_VERSION_base(4,15,0) +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +unsafeWithForeignPtr = withForeignPtr +#endif + +--------------------------------------------------------------- +-- BinData +--------------------------------------------------------------- + +data BinData = BinData Int BinArray + +instance NFData BinData where + rnf (BinData sz _) = rnf sz + +instance Binary BinData where + put_ bh (BinData sz dat) = do + put_ bh sz + putPrim bh sz $ \dest -> + unsafeWithForeignPtr dat $ \orig -> + copyBytes dest orig sz + -- + get bh = do + sz <- get bh + dat <- mallocForeignPtrBytes sz + getPrim bh sz $ \orig -> + unsafeWithForeignPtr dat $ \dest -> + copyBytes dest orig sz + return (BinData sz dat) + +dataHandle :: BinData -> IO ReadBinHandle +dataHandle (BinData size bin) = do + ixr <- newFastMutInt 0 + return (ReadBinMem noReaderUserData ixr size bin) + +handleData :: WriteBinHandle -> IO BinData +handleData (WriteBinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr + +--------------------------------------------------------------- +-- FullBinData +--------------------------------------------------------------- + +-- | 'FullBinData' stores a slice to a 'BinArray'. +-- +-- It requires less memory than 'ReadBinHandle', and can be constructed from +-- a 'ReadBinHandle' via 'freezeBinHandle' and turned back into a +-- 'ReadBinHandle' using 'thawBinHandle'. +-- Additionally, the byte array slice can be put into a 'WriteBinHandle' without extra +-- conversions via 'putFullBinData'. +data FullBinData = FullBinData + { fbd_readerUserData :: ReaderUserData + -- ^ 'ReaderUserData' that can be used to resume reading. + , fbd_off_s :: {-# UNPACK #-} !Int + -- ^ start offset + , fbd_off_e :: {-# UNPACK #-} !Int + -- ^ end offset + , fbd_size :: {-# UNPACK #-} !Int + -- ^ total buffer size + , fbd_buffer :: {-# UNPACK #-} !BinArray + } + +-- Equality and Ord assume that two distinct buffers are different, even if they compare the same things. +instance Eq FullBinData where + (FullBinData _ b c d e) == (FullBinData _ b1 c1 d1 e1) = b == b1 && c == c1 && d == d1 && e == e1 + +instance Ord FullBinData where + compare (FullBinData _ b c d e) (FullBinData _ b1 c1 d1 e1) = + compare b b1 `mappend` compare c c1 `mappend` compare d d1 `mappend` compare e e1 + +-- | Write the 'FullBinData' slice into the 'WriteBinHandle'. +putFullBinData :: WriteBinHandle -> FullBinData -> IO () +putFullBinData bh (FullBinData _ o1 o2 _sz ba) = do + let sz = o2 - o1 + putPrim bh sz $ \dest -> + unsafeWithForeignPtr (ba `plusForeignPtr` o1) $ \orig -> + copyBytes dest orig sz + +-- | Freeze a 'ReadBinHandle' and a start index into a 'FullBinData'. +-- +-- 'FullBinData' stores a slice starting from the 'Bin a' location to the current +-- offset of the 'ReadBinHandle'. +freezeBinHandle :: ReadBinHandle -> Bin a -> IO FullBinData +freezeBinHandle (ReadBinMem user_data ixr sz binr) (BinPtr start) = do + ix <- readFastMutInt ixr + pure (FullBinData user_data start ix sz binr) + +-- | Turn the 'FullBinData' into a 'ReadBinHandle', setting the 'ReadBinHandle' +-- offset to the start of the 'FullBinData' and restore the 'ReaderUserData' that was +-- obtained from 'freezeBinHandle'. +thawBinHandle :: FullBinData -> IO ReadBinHandle +thawBinHandle (FullBinData user_data ix _end sz ba) = do + ixr <- newFastMutInt ix + return $ ReadBinMem user_data ixr sz ba + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +-- | A write-only handle that can be used to serialise binary data into a buffer. +-- +-- The buffer is an unboxed binary array. +data WriteBinHandle + = WriteBinMem { + wbm_userData :: WriterUserData, + -- ^ User data for writing binary outputs. + -- Allows users to overwrite certain 'Binary' instances. + -- This is helpful when a non-canonical 'Binary' instance is required, + -- such as in the case of 'Name'. + wbm_off_r :: !FastMutInt, -- ^ the current offset + wbm_sz_r :: !FastMutInt, -- ^ size of the array (cached) + wbm_arr_r :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1)) + } + +-- | A read-only handle that can be used to deserialise binary data from a buffer. +-- +-- The buffer is an unboxed binary array. +data ReadBinHandle + = ReadBinMem { + rbm_userData :: ReaderUserData, + -- ^ User data for reading binary inputs. + -- Allows users to overwrite certain 'Binary' instances. + -- This is helpful when a non-canonical 'Binary' instance is required, + -- such as in the case of 'Name'. + rbm_off_r :: !FastMutInt, -- ^ the current offset + rbm_sz_r :: !Int, -- ^ size of the array (cached) + rbm_arr_r :: !BinArray -- ^ the array (bounds: (0,size-1)) + } + +getReaderUserData :: ReadBinHandle -> ReaderUserData +getReaderUserData bh = rbm_userData bh + +getWriterUserData :: WriteBinHandle -> WriterUserData +getWriterUserData bh = wbm_userData bh + +setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle +setWriterUserData bh us = bh { wbm_userData = us } + +setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle +setReaderUserData bh us = bh { rbm_userData = us } + +-- | Add 'SomeBinaryReader' as a known binary decoder. +-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData', +-- it is overwritten. +addReaderToUserData :: forall a. Typeable a => BinaryReader a -> ReadBinHandle -> ReadBinHandle +addReaderToUserData reader bh = bh + { rbm_userData = (rbm_userData bh) + { ud_reader_data = + let + typRep = Refl.typeRep @a + in + Map.insert (SomeTypeRep typRep) (SomeBinaryReader typRep reader) (ud_reader_data (rbm_userData bh)) + } + } + +-- | Add 'SomeBinaryWriter' as a known binary encoder. +-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData', +-- it is overwritten. +addWriterToUserData :: forall a . Typeable a => BinaryWriter a -> WriteBinHandle -> WriteBinHandle +addWriterToUserData writer bh = bh + { wbm_userData = (wbm_userData bh) + { ud_writer_data = + let + typRep = Refl.typeRep @a + in + Map.insert (SomeTypeRep typRep) (SomeBinaryWriter typRep writer) (ud_writer_data (wbm_userData bh)) + } + } + +-- | Get access to the underlying buffer. +withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a +withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do + ix <- readFastMutInt ix_r + arr <- readIORef arr_r + action $ BS.fromForeignPtr arr 0 ix + +unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle +unsafeUnpackBinBuffer (BS.BS arr len) = do + ix_r <- newFastMutInt 0 + return (ReadBinMem noReaderUserData ix_r len arr) + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +-- | Like a 'Bin' but is used to store relative offset pointers. +-- Relative offset pointers store a relative location, but also contain an +-- anchor that allow to obtain the absolute offset. +data RelBin a = RelBin + { relBin_anchor :: {-# UNPACK #-} !(Bin a) + -- ^ Absolute position from where we read 'relBin_offset'. + , relBin_offset :: {-# UNPACK #-} !(RelBinPtr a) + -- ^ Relative offset to 'relBin_anchor'. + -- The absolute position of the 'RelBin' is @relBin_anchor + relBin_offset@ + } + deriving (Eq, Ord, Show, Bounded) + +-- | A 'RelBinPtr' is like a 'Bin', but contains a relative offset pointer +-- instead of an absolute offset. +newtype RelBinPtr a = RelBinPtr (Bin a) + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i) = BinPtr i + +-- | Read a relative offset location and wrap it in 'RelBin'. +-- +-- The resulting 'RelBin' can be translated into an absolute offset location using +-- 'makeAbsoluteBin' +getRelBin :: ReadBinHandle -> IO (RelBin a) +getRelBin bh = do + start <- tellBinReader bh + off <- get bh + pure $ RelBin start off + +makeAbsoluteBin :: RelBin a -> Bin a +makeAbsoluteBin (RelBin (BinPtr !start) (RelBinPtr (BinPtr !offset))) = + BinPtr $ start + offset +{-# INLINE makeAbsoluteBin #-} + +makeRelativeBin :: RelBin a -> RelBinPtr a +makeRelativeBin (RelBin _ offset) = offset + +toRelBin :: Bin (RelBinPtr a) -> Bin a -> RelBin a +toRelBin (BinPtr !start) (BinPtr !goal) = + RelBin (BinPtr start) (RelBinPtr $ BinPtr $ goal - start) + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +-- | Do not rely on instance sizes for general types, +-- we use variable length encoding for many of them. +class Binary a where + put_ :: WriteBinHandle -> a -> IO () + put :: WriteBinHandle -> a -> IO (Bin a) + get :: ReadBinHandle -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do _ <- put bh a; return () + put bh a = do p <- tellBinWriter bh; put_ bh a; return p + +putAt :: Binary a => WriteBinHandle -> Bin a -> a -> IO () +putAt bh p x = do seekBinWriter bh p; put_ bh x; return () + +putAtRel :: WriteBinHandle -> Bin (RelBinPtr a) -> Bin a -> IO () +putAtRel bh from to = putAt bh from (makeRelativeBin $ toRelBin from to) + +getAt :: Binary a => ReadBinHandle -> Bin a -> IO a +getAt bh p = do seekBinReader bh p; get bh + +openBinMem :: Int -> IO WriteBinHandle +openBinMem size + | size <= 0 = error "GHC.Iface.Ext.Binary.Utils.openBinMem: size must be >= 0" + | otherwise = do + arr <- mallocForeignPtrBytes size + arr_r <- newIORef arr + ix_r <- newFastMutInt 0 + sz_r <- newFastMutInt size + return WriteBinMem + { wbm_userData = noWriterUserData + , wbm_off_r = ix_r + , wbm_sz_r = sz_r + , wbm_arr_r = arr_r + } + +-- | Freeze the given 'WriteBinHandle' and turn it into an equivalent 'ReadBinHandle'. +-- +-- The current offset of the 'WriteBinHandle' is maintained in the new 'ReadBinHandle'. +freezeWriteHandle :: WriteBinHandle -> IO ReadBinHandle +freezeWriteHandle wbm = do + rbm_off_r <- newFastMutInt =<< readFastMutInt (wbm_off_r wbm) + rbm_sz_r <- readFastMutInt (wbm_sz_r wbm) + rbm_arr_r <- readIORef (wbm_arr_r wbm) + pure $ ReadBinMem + { rbm_userData = noReaderUserData + , rbm_off_r = rbm_off_r + , rbm_sz_r = rbm_sz_r + , rbm_arr_r = rbm_arr_r + } + +-- | Copy the BinBuffer to a new BinBuffer which is exactly the right size. +-- This performs a copy of the underlying buffer. +-- The buffer may be truncated if the offset is not at the end of the written +-- output. +-- +-- UserData is also discarded during the copy +-- You should just use this when translating a Put handle into a Get handle. +shrinkBinBuffer :: WriteBinHandle -> IO ReadBinHandle +shrinkBinBuffer bh = withBinBuffer bh $ \bs -> do + unsafeUnpackBinBuffer (copy bs) + +thawReadHandle :: ReadBinHandle -> IO WriteBinHandle +thawReadHandle rbm = do + wbm_off_r <- newFastMutInt =<< readFastMutInt (rbm_off_r rbm) + wbm_sz_r <- newFastMutInt (rbm_sz_r rbm) + wbm_arr_r <- newIORef (rbm_arr_r rbm) + pure $ WriteBinMem + { wbm_userData = noWriterUserData + , wbm_off_r = wbm_off_r + , wbm_sz_r = wbm_sz_r + , wbm_arr_r = wbm_arr_r + } + +tellBinWriter :: WriteBinHandle -> IO (Bin a) +tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +tellBinReader :: ReadBinHandle -> IO (Bin a) +tellBinReader (ReadBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +seekBinWriter :: WriteBinHandle -> Bin a -> IO () +seekBinWriter h@(WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p > sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +-- | 'seekBinNoExpandWriter' moves the index pointer to the location pointed to +-- by 'Bin a'. +-- This operation may 'panic', if the pointer location is out of bounds of the +-- buffer of 'BinHandle'. +seekBinNoExpandWriter :: WriteBinHandle -> Bin a -> IO () +seekBinNoExpandWriter (WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p > sz) + then panic "seekBinNoExpandWriter: seek out of range" + else writeFastMutInt ix_r p + +-- | SeekBin but without calling expandBin +seekBinReader :: ReadBinHandle -> Bin a -> IO () +seekBinReader (ReadBinMem _ ix_r sz_r _) (BinPtr !p) = do + if (p > sz_r) + then panic "seekBinReader: seek out of range" + else writeFastMutInt ix_r p + +advance :: ReadBinHandle -> Int -> IO () +advance (ReadBinMem _ ix_r sz_r _) !n = do + !p <- readFastMutInt ix_r + let !np = p + n + if (np > sz_r) + then panic "advance: seek out of range" + else writeFastMutInt ix_r np + +seekBinReaderRel :: ReadBinHandle -> RelBin a -> IO () +seekBinReaderRel (ReadBinMem _ ix_r sz_r _) relBin = do + let (BinPtr !p) = makeAbsoluteBin relBin + if (p > sz_r) + then panic "seekBinReaderRel: seek out of range" + else writeFastMutInt ix_r p + +writeBinMem :: WriteBinHandle -> FilePath -> IO () +writeBinMem (WriteBinMem _ ix_r _ arr_r) fn = do + h <- openBinaryFile fn WriteMode + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix + hClose h + +readBinMem :: FilePath -> IO ReadBinHandle +readBinMem filename = do + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + readBinMem_ filesize h + +readBinMemN :: Int -> FilePath -> IO (Maybe ReadBinHandle) +readBinMemN size filename = do + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + if filesize < size + then pure Nothing + else Just <$> readBinMem_ size h + +readBinMem_ :: Int -> Handle -> IO ReadBinHandle +readBinMem_ filesize h = do + arr <- mallocForeignPtrBytes filesize + count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize + when (count /= filesize) $ + error ("Binary.readBinMem: only read " ++ show count ++ " bytes") + ix_r <- newFastMutInt 0 + return ReadBinMem + { rbm_userData = noReaderUserData + , rbm_off_r = ix_r + , rbm_sz_r = filesize + , rbm_arr_r = arr + } + +-- expand the size of the array to include a specified offset +expandBin :: WriteBinHandle -> Int -> IO () +expandBin (WriteBinMem _ _ sz_r arr_r) !off = do + !sz <- readFastMutInt sz_r + let !sz' = getSize sz + arr <- readIORef arr_r + arr' <- mallocForeignPtrBytes sz' + withForeignPtr arr $ \old -> + withForeignPtr arr' $ \new -> + copyBytes new old sz + writeFastMutInt sz_r sz' + writeIORef arr_r arr' + where + getSize :: Int -> Int + getSize !sz + | sz > off + = sz + | otherwise + = getSize (sz * 2) + +foldGet + :: Binary a + => Word -- n elements + -> ReadBinHandle + -> b -- initial accumulator + -> (Word -> a -> b -> IO b) + -> IO b +foldGet n bh init_b f = go 0 init_b + where + go i b + | i == n = return b + | otherwise = do + a <- get bh + b' <- f i a b + go (i+1) b' + +foldGet' + :: Binary a + => Word -- n elements + -> ReadBinHandle + -> b -- initial accumulator + -> (Word -> a -> b -> IO b) + -> IO b +{-# INLINE foldGet' #-} +foldGet' n bh init_b f = go 0 init_b + where + go i !b + | i == n = return b + | otherwise = do + !a <- get bh + b' <- f i a b + go (i+1) b' + + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +-- | Takes a size and action writing up to @size@ bytes. +-- After the action has run advance the index to the buffer +-- by size bytes. +putPrim :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () +putPrim h@(WriteBinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix + size > sz) $ + expandBin h (ix + size) + arr <- readIORef arr_r + unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix) + writeFastMutInt ix_r (ix + size) + +-- -- | Similar to putPrim but advances the index by the actual number of +-- -- bytes written. +-- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () +-- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do +-- ix <- readFastMutInt ix_r +-- sz <- readFastMutInt sz_r +-- when (ix + size > sz) $ +-- expandBin h (ix + size) +-- arr <- readIORef arr_r +-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) +-- writeFastMutInt ix_r (ix + written) + +getPrim :: ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a +getPrim (ReadBinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + when (ix + size > sz_r) $ + ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) + w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix) + -- This is safe WRT #17760 as we we guarantee that the above line doesn't + -- diverge + writeFastMutInt ix_r (ix + size) + return w + +putWord8 :: WriteBinHandle -> Word8 -> IO () +putWord8 h !w = putPrim h 1 (\op -> poke op w) + +getWord8 :: ReadBinHandle -> IO Word8 +getWord8 h = getPrim h 1 peek + +putWord16 :: WriteBinHandle -> Word16 -> IO () +putWord16 h w = putPrim h 2 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) + pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) + ) + +getWord16 :: ReadBinHandle -> IO Word16 +getWord16 h = getPrim h 2 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + return $! w0 `shiftL` 8 .|. w1 + ) + +putWord32 :: WriteBinHandle -> Word32 -> IO () +putWord32 h w = putPrim h 4 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) + ) + +getWord32 :: ReadBinHandle -> IO Word32 +getWord32 h = getPrim h 4 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + + return $! (w0 `shiftL` 24) .|. + (w1 `shiftL` 16) .|. + (w2 `shiftL` 8) .|. + w3 + ) + +putWord64 :: WriteBinHandle -> Word64 -> IO () +putWord64 h w = putPrim h 8 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) + pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) + pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) + ) + +getWord64 :: ReadBinHandle -> IO Word64 +getWord64 h = getPrim h 8 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + w4 <- fromIntegral <$> peekElemOff op 4 + w5 <- fromIntegral <$> peekElemOff op 5 + w6 <- fromIntegral <$> peekElemOff op 6 + w7 <- fromIntegral <$> peekElemOff op 7 + + return $! (w0 `shiftL` 56) .|. + (w1 `shiftL` 48) .|. + (w2 `shiftL` 40) .|. + (w3 `shiftL` 32) .|. + (w4 `shiftL` 24) .|. + (w5 `shiftL` 16) .|. + (w6 `shiftL` 8) .|. + w7 + ) + +putByte :: WriteBinHandle -> Word8 -> IO () +putByte bh !w = putWord8 bh w + +getByte :: ReadBinHandle -> IO Word8 +getByte h = getWord8 h + +-- ----------------------------------------------------------------------------- +-- Encode numbers in LEB128 encoding. +-- Requires one byte of space per 7 bits of data. +-- +-- There are signed and unsigned variants. +-- Do NOT use the unsigned one for signed values, at worst it will +-- result in wrong results, at best it will lead to bad performance +-- when coercing negative values to an unsigned type. +-- +-- We mark them as SPECIALIZE as it's extremely critical that they get specialized +-- to their specific types. +-- +-- TODO: Each use of putByte performs a bounds check, +-- we should use putPrimMax here. However it's quite hard to return +-- the number of bytes written into putPrimMax without allocating an +-- Int for it, while the code below does not allocate at all. +-- So we eat the cost of the bounds check instead of increasing allocations +-- for now. + +-- Unsigned numbers +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int16 -> IO () #-} +putULEB128 :: forall a. (Integral a, FiniteBits a) => WriteBinHandle -> a -> IO () +putULEB128 bh w = +#if defined(DEBUG) + (if w < 0 then panic "putULEB128: Signed number" else id) $ +#endif + go w + where + go :: a -> IO () + go w + | w <= (127 :: a) + = putByte bh (fromIntegral w :: Word8) + | otherwise = do + -- bit 7 (8th bit) indicates more to come. + let !byte = setBit (fromIntegral w) 7 :: Word8 + putByte bh byte + go (w `unsafeShiftR` 7) + +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word64 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word32 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word16 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int64 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int32 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int16 #-} +getULEB128 :: forall a. (Integral a, FiniteBits a) => ReadBinHandle -> IO a +getULEB128 bh = + go 0 0 + where + go :: Int -> a -> IO a + go shift w = do + b <- getByte bh + let !hasMore = testBit b 7 + let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a + if hasMore + then do + go (shift+7) val + else + return $! val + +-- Signed numbers +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-} +putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO () +putSLEB128 bh initial = go initial + where + go :: a -> IO () + go val = do + let !byte = fromIntegral (clearBit val 7) :: Word8 + let !val' = val `unsafeShiftR` 7 + let !signBit = testBit byte 6 + let !done = + -- Unsigned value, val' == 0 and last value can + -- be discriminated from a negative number. + ((val' == 0 && not signBit) || + -- Signed value, + (val' == -1 && signBit)) + + let !byte' = if done then byte else setBit byte 7 + putByte bh byte' + + unless done $ go val' + +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word64 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word32 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word16 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int64 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int32 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int16 #-} +getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => ReadBinHandle -> IO a +getSLEB128 bh = do + (val,shift,signed) <- go 0 0 + if signed && (shift < finiteBitSize val ) + then return $! ((complement 0 `unsafeShiftL` shift) .|. val) + else return val + where + go :: Int -> a -> IO (a,Int,Bool) + go shift val = do + byte <- getByte bh + let !byteVal = fromIntegral (clearBit byte 7) :: a + let !val' = val .|. (byteVal `unsafeShiftL` shift) + let !more = testBit byte 7 + let !shift' = shift+7 + if more + then go (shift') val' + else do + let !signed = testBit byte 6 + return (val',shift',signed) + +-- ----------------------------------------------------------------------------- +-- Fixed length encoding instances + +-- Sometimes words are used to represent a certain bit pattern instead +-- of a number. Using FixedLengthEncoding we will write the pattern as +-- is to the interface file without the variable length encoding we usually +-- apply. + +-- | Encode the argument in its full length. This is different from many default +-- binary instances which make no guarantee about the actual encoding and +-- might do things using variable length encoding. +newtype FixedLengthEncoding a + = FixedLengthEncoding { unFixedLength :: a } + deriving (Eq,Ord,Show) + +instance Binary (FixedLengthEncoding Word8) where + put_ h (FixedLengthEncoding x) = putByte h x + get h = FixedLengthEncoding <$> getByte h + +instance Binary (FixedLengthEncoding Word16) where + put_ h (FixedLengthEncoding x) = putWord16 h x + get h = FixedLengthEncoding <$> getWord16 h + +instance Binary (FixedLengthEncoding Word32) where + put_ h (FixedLengthEncoding x) = putWord32 h x + get h = FixedLengthEncoding <$> getWord32 h + +instance Binary (FixedLengthEncoding Word64) where + put_ h (FixedLengthEncoding x) = putWord64 h x + get h = FixedLengthEncoding <$> getWord64 h + +-- ----------------------------------------------------------------------------- +-- Primitive Word writes + +instance Binary Word8 where + put_ bh !w = putWord8 bh w + get = getWord8 + +instance Binary Word16 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word32 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word64 where + put_ = putULEB128 + get = getULEB128 + +-- ----------------------------------------------------------------------------- +-- Primitive Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int32 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int64 where + put_ h w = putSLEB128 h w + get h = getSLEB128 h + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ _ () = return () + get _ = return () + +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 Binary Int where + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) + +instance Binary a => Binary [a] where + put_ bh l = do + let len = length l + put_ bh len + mapM_ (put_ bh) l + get bh = do + len <- get bh :: IO Int -- Int is variable length encoded so only + -- one byte for small lists. + let loop 0 = return [] + loop n = do a <- get bh; as <- loop (n-1); return (a:as) + loop len + +-- | This instance doesn't rely on the determinism of the keys' 'Ord' instance, +-- so it works e.g. for 'Name's too. +instance (Binary a, Ord a) => Binary (Set a) where + put_ bh s = put_ bh (Set.toList s) + get bh = Set.fromList <$> get bh + +instance Binary a => Binary (NonEmpty a) where + put_ bh = put_ bh . NonEmpty.toList + get bh = NonEmpty.fromList <$> get bh + +instance (Ix a, Binary a, Binary b) => Binary (Array a b) where + put_ bh arr = do + put_ bh $ bounds arr + put_ bh $ elems arr + get bh = do + bounds <- get bh + xs <- get bh + return $ listArray bounds xs + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where + put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where + put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where + put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + g <- get bh + return (a,b,c,d,e,f,g) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = putByte bh 0 + put_ bh (Just a) = do putByte bh 1; put_ bh a + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance Binary a => Binary (Strict.Maybe a) where + put_ bh Strict.Nothing = putByte bh 0 + put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a + get bh = + do h <- getWord8 bh + case h of + 0 -> return Strict.Nothing + _ -> do x <- get bh; return (Strict.Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do putByte bh 0; put_ bh a + put_ bh (Right b) = do putByte bh 1; put_ bh b + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance Binary JoinPointHood where + put_ bh NotJoinPoint = putByte bh 0 + put_ bh (JoinPoint ar) = do + putByte bh 1 + put_ bh ar + get bh = do + h <- getByte bh + case h of + 0 -> return NotJoinPoint + _ -> do { ar <- get bh; return (JoinPoint ar) } + +{- +Finally - a reasonable portable Integer instance. + +We used to encode values in the Int32 range as such, +falling back to a string of all things. In either case +we stored a tag byte to discriminate between the two cases. + +This made some sense as it's highly portable but also not very +efficient. + +However GHC stores a surprisingly large number of large Integer +values. In the examples looked at between 25% and 50% of Integers +serialized were outside of the Int32 range. + +Consider a value like `2724268014499746065`, some sort of hash +actually generated by GHC. +In the old scheme this was encoded as a list of 19 chars. This +gave a size of 77 Bytes, one for the length of the list and 76 +since we encode chars as Word32 as well. + +We can easily do better. The new plan is: + +* Start with a tag byte + * 0 => Int64 (LEB128 encoded) + * 1 => Negative large integer + * 2 => Positive large integer +* Followed by the value: + * Int64 is encoded as usual + * Large integers are encoded as a list of bytes (Word8). + We use Data.Bits which defines a bit order independent of the representation. + Values are stored LSB first. + +This means our example value `2724268014499746065` is now only 10 bytes large. +* One byte tag +* One byte for the length of the [Word8] list. +* 8 bytes for the actual date. + +The new scheme also does not depend in any way on +architecture specific details. + +We still use this scheme even with LEB128 available, +as it has less overhead for truly large numbers. (> maxBound :: Int64) + +The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal +-} + +instance Binary Integer where + put_ bh i + | i >= lo64 && i <= hi64 = do + putWord8 bh 0 + put_ bh (fromIntegral i :: Int64) + | otherwise = do + if i < 0 + then putWord8 bh 1 + else putWord8 bh 2 + put_ bh (unroll $ abs i) + where + lo64 = fromIntegral (minBound :: Int64) + hi64 = fromIntegral (maxBound :: Int64) + get bh = do + int_kind <- getWord8 bh + case int_kind of + 0 -> fromIntegral <$!> (get bh :: IO Int64) + -- Large integer + 1 -> negate <$!> getInt + 2 -> getInt + _ -> panic "Binary Integer - Invalid byte" + where + getInt :: IO Integer + getInt = roll <$!> (get bh :: IO [Word8]) + +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldl' unstep 0 . reverse + where + unstep a b = a `shiftL` 8 .|. fromIntegral b + + + {- + -- This code is currently commented out. + -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for + -- discussion. + + put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) + put_ bh (J# s# a#) = do + putByte bh 1 + put_ bh (I# s#) + let sz# = sizeofByteArray# a# -- in *bytes* + put_ bh (I# sz#) -- in *bytes* + putByteArray bh a# sz# + + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () +putByteArray bh a s# = loop 0# + where loop n# + | n# ==# s# = return () + | otherwise = do + putByte bh (indexByteArray a n#) + loop (n# +# 1#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + -} + +{- +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () +writeByteArray arr i (W8# w) = IO $ \s -> + case writeWord8Array# arr i w s of { s -> + (# s, () #) } + +indexByteArray :: ByteArray# -> Int# -> Word8 +indexByteArray a# n# = W8# (indexWord8Array# a# n#) + +-} +instance (Binary a) => Binary (Ratio a) where + put_ bh (a :% b) = do put_ bh a; put_ bh b + get bh = do a <- get bh; b <- get bh; return (a :% b) + +-- Instance uses fixed-width encoding to allow inserting +-- Bin placeholders in the stream. +instance Binary (Bin a) where + put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) + get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) + +-- Instance uses fixed-width encoding to allow inserting +-- Bin placeholders in the stream. +instance Binary (RelBinPtr a) where + put_ bh (RelBinPtr i) = put_ bh i + get bh = RelBinPtr <$> get bh + +-- ----------------------------------------------------------------------------- +-- Forward reading/writing + +-- | @'forwardPut' put_A put_B@ outputs A after B but allows A to be read before B +-- by using a forward reference. +forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b) +forwardPut bh put_A put_B = do + -- write placeholder pointer to A + pre_a <- tellBinWriter bh + put_ bh pre_a + + -- write B + r_b <- put_B + + -- update A's pointer + a <- tellBinWriter bh + putAt bh pre_a a + seekBinNoExpandWriter bh a + + -- write A + r_a <- put_A r_b + pure (r_a,r_b) + +forwardPut_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO () +forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B + +-- | Read a value stored using a forward reference +-- +-- The forward reference is expected to be an absolute offset. +forwardGet :: ReadBinHandle -> IO a -> IO a +forwardGet bh get_A = do + -- read forward reference + p <- get bh -- a BinPtr + -- store current position + p_a <- tellBinReader bh + -- go read the forward value, then seek back + seekBinReader bh p + r <- get_A + seekBinReader bh p_a + pure r + +-- | @'forwardPutRel' put_A put_B@ outputs A after B but allows A to be read before B +-- by using a forward reference. +-- +-- This forward reference is a relative offset that allows us to skip over the +-- result of 'put_A'. +forwardPutRel :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b) +forwardPutRel bh put_A put_B = do + -- write placeholder pointer to A + pre_a <- tellBinWriter bh + put_ bh pre_a + + -- write B + r_b <- put_B + + -- update A's pointer + a <- tellBinWriter bh + putAtRel bh pre_a a + seekBinNoExpandWriter bh a + + -- write A + r_a <- put_A r_b + pure (r_a,r_b) + +-- | Like 'forwardGetRel', but discard the result. +forwardPutRel_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO () +forwardPutRel_ bh put_A put_B = void $ forwardPutRel bh put_A put_B + +-- | Read a value stored using a forward reference. +-- +-- The forward reference is expected to be a relative offset. +forwardGetRel :: ReadBinHandle -> IO a -> IO a +forwardGetRel bh get_A = do + -- read forward reference + p <- getRelBin bh + -- store current position + p_a <- tellBinReader bh + -- go read the forward value, then seek back + seekBinReader bh $ makeAbsoluteBin p + r <- get_A + seekBinReader bh p_a + pure r + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyPut :: Binary a => WriteBinHandle -> a -> IO () +lazyPut = lazyPut' put_ + +lazyGet :: Binary a => ReadBinHandle -> IO a +lazyGet = lazyGet' get + +lazyPut' :: (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO () +lazyPut' f bh a = do + -- output the obj with a ptr to skip over it: + pre_a <- tellBinWriter bh + put_ bh pre_a -- save a slot for the ptr + f bh a -- dump the object + q <- tellBinWriter bh -- q = ptr to after object + putAtRel bh pre_a q -- fill in slot before a with ptr to q + seekBinWriter bh q -- finally carry on writing at q + +lazyGet' :: (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a +lazyGet' f bh = do + p <- getRelBin bh -- a BinPtr + p_a <- tellBinReader bh + a <- unsafeInterleaveIO $ do + -- NB: Use a fresh rbm_off_r variable in the child thread, for thread + -- safety. + off_r <- newFastMutInt 0 + let bh' = bh { rbm_off_r = off_r } + seekBinReader bh' p_a + f bh' + seekBinReader bh (makeAbsoluteBin p) -- skip over the object for now + return a + +-- | Serialize the constructor strictly but lazily serialize a value inside a +-- 'Just'. +-- +-- This way we can check for the presence of a value without deserializing the +-- value itself. +lazyPutMaybe :: Binary a => WriteBinHandle -> Maybe a -> IO () +lazyPutMaybe bh Nothing = putWord8 bh 0 +lazyPutMaybe bh (Just x) = do + putWord8 bh 1 + lazyPut bh x + +-- | Deserialize a value serialized by 'lazyPutMaybe'. +lazyGetMaybe :: Binary a => ReadBinHandle -> IO (Maybe a) +lazyGetMaybe bh = do + h <- getWord8 bh + case h of + 0 -> pure Nothing + _ -> Just <$> lazyGet bh + +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +-- Note [Binary UserData] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- Information we keep around during interface file +-- serialization/deserialization. Namely we keep the functions for serializing +-- and deserializing 'Name's and 'FastString's. We do this because we actually +-- use serialization in two distinct settings, +-- +-- * When serializing interface files themselves +-- +-- * When computing the fingerprint of an IfaceDecl (which we computing by +-- hashing its Binary serialization) +-- +-- These two settings have different needs while serializing Names: +-- +-- * Names in interface files are serialized via a symbol table (see Note +-- [Symbol table representation of names] in "GHC.Iface.Binary"). +-- +-- * During fingerprinting a binding Name is serialized as the OccName and a +-- non-binding Name is serialized as the fingerprint of the thing they +-- represent. See Note [Fingerprinting IfaceDecls] for further discussion. +-- + +-- | Newtype to serialise binding names differently to non-binding 'Name'. +-- See Note [Binary UserData] +newtype BindingName = BindingName { getBindingName :: Name } + deriving ( Eq ) + +simpleBindingNameWriter :: BinaryWriter Name -> BinaryWriter BindingName +simpleBindingNameWriter = coerce + +simpleBindingNameReader :: BinaryReader Name -> BinaryReader BindingName +simpleBindingNameReader = coerce + +-- | Existential for 'BinaryWriter' with a type witness. +data SomeBinaryWriter = forall a . SomeBinaryWriter (Refl.TypeRep a) (BinaryWriter a) + +-- | Existential for 'BinaryReader' with a type witness. +data SomeBinaryReader = forall a . SomeBinaryReader (Refl.TypeRep a) (BinaryReader a) + +-- | UserData required to serialise symbols for interface files. +-- +-- See Note [Binary UserData] +data WriterUserData = + WriterUserData { + ud_writer_data :: Map SomeTypeRep SomeBinaryWriter + -- ^ A mapping from a type witness to the 'Writer' for the associated type. + -- This is a 'Map' because microbenchmarks indicated this is more efficient + -- than other representations for less than ten elements. + -- + -- Considered representations: + -- + -- * [(TypeRep, SomeBinaryWriter)] + -- * bytehash (on hackage) + -- * Map TypeRep SomeBinaryWriter + } + +-- | UserData required to deserialise symbols for interface files. +-- +-- See Note [Binary UserData] +data ReaderUserData = + ReaderUserData { + ud_reader_data :: Map SomeTypeRep SomeBinaryReader + -- ^ A mapping from a type witness to the 'Reader' for the associated type. + -- This is a 'Map' because microbenchmarks indicated this is more efficient + -- than other representations for less than ten elements. + -- + -- Considered representations: + -- + -- * [(TypeRep, SomeBinaryReader)] + -- * bytehash (on hackage) + -- * Map TypeRep SomeBinaryReader + } + +mkWriterUserData :: [SomeBinaryWriter] -> WriterUserData +mkWriterUserData caches = noWriterUserData + { ud_writer_data = Map.fromList $ map (\cache@(SomeBinaryWriter typRep _) -> (SomeTypeRep typRep, cache)) caches + } + +mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData +mkReaderUserData caches = noReaderUserData + { ud_reader_data = Map.fromList $ map (\cache@(SomeBinaryReader typRep _) -> (SomeTypeRep typRep, cache)) caches + } + +mkSomeBinaryWriter :: forall a . Refl.Typeable a => BinaryWriter a -> SomeBinaryWriter +mkSomeBinaryWriter cb = SomeBinaryWriter (Refl.typeRep @a) cb + +mkSomeBinaryReader :: forall a . Refl.Typeable a => BinaryReader a -> SomeBinaryReader +mkSomeBinaryReader cb = SomeBinaryReader (Refl.typeRep @a) cb + +newtype BinaryReader s = BinaryReader + { getEntry :: ReadBinHandle -> IO s + } deriving (Functor) + +newtype BinaryWriter s = BinaryWriter + { putEntry :: WriteBinHandle -> s -> IO () + } + +mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s +mkWriter f = BinaryWriter + { putEntry = f + } + +mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s +mkReader f = BinaryReader + { getEntry = f + } + +-- | Find the 'BinaryReader' for the 'Binary' instance for the type identified by 'Proxy a'. +-- +-- If no 'BinaryReader' has been configured before, this function will panic. +findUserDataReader :: forall a . Refl.Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a +findUserDataReader query bh = + case Map.lookup (Refl.someTypeRep query) (ud_reader_data $ getReaderUserData bh) of + Nothing -> panic $ "Failed to find BinaryReader for the key: " ++ show (Refl.someTypeRep query) + Just (SomeBinaryReader _ (reader :: BinaryReader x)) -> + unsafeCoerce @(BinaryReader x) @(BinaryReader a) reader + -- This 'unsafeCoerce' could be written safely like this: + -- + -- @ + -- Just (SomeBinaryReader _ (reader :: BinaryReader x)) -> + -- case testEquality (typeRep @a) tyRep of + -- Just Refl -> coerce @(BinaryReader x) @(BinaryReader a) reader + -- Nothing -> panic $ "Invariant violated" + -- @ + -- + -- But it comes at a slight performance cost and this function is used in + -- binary serialisation hot loops, thus, we prefer the small performance boost over + -- the additional type safety. + +-- | Find the 'BinaryWriter' for the 'Binary' instance for the type identified by 'Proxy a'. +-- +-- If no 'BinaryWriter' has been configured before, this function will panic. +findUserDataWriter :: forall a . Refl.Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a +findUserDataWriter query bh = + case Map.lookup (Refl.someTypeRep query) (ud_writer_data $ getWriterUserData bh) of + Nothing -> panic $ "Failed to find BinaryWriter for the key: " ++ show (Refl.someTypeRep query) + Just (SomeBinaryWriter _ (writer :: BinaryWriter x)) -> + unsafeCoerce @(BinaryWriter x) @(BinaryWriter a) writer + -- This 'unsafeCoerce' could be written safely like this: + -- + -- @ + -- Just (SomeBinaryWriter tyRep (writer :: BinaryWriter x)) -> + -- case testEquality (typeRep @a) tyRep of + -- Just Refl -> coerce @(BinaryWriter x) @(BinaryWriter a) writer + -- Nothing -> panic $ "Invariant violated" + -- @ + -- + -- But it comes at a slight performance cost and this function is used in + -- binary serialisation hot loops, thus, we prefer the small performance boost over + -- the additional type safety. + + +noReaderUserData :: ReaderUserData +noReaderUserData = ReaderUserData + { ud_reader_data = Map.empty + } + +noWriterUserData :: WriterUserData +noWriterUserData = WriterUserData + { ud_writer_data = Map.empty + } + +newReadState :: (ReadBinHandle -> IO Name) -- ^ how to deserialize 'Name's + -> (ReadBinHandle -> IO FastString) + -> ReaderUserData +newReadState get_name get_fs = + mkReaderUserData + [ mkSomeBinaryReader $ mkReader get_name + , mkSomeBinaryReader $ mkReader @BindingName (coerce get_name) + , mkSomeBinaryReader $ mkReader get_fs + ] + +newWriteState :: (WriteBinHandle -> Name -> IO ()) + -- ^ how to serialize non-binding 'Name's + -> (WriteBinHandle -> Name -> IO ()) + -- ^ how to serialize binding 'Name's + -> (WriteBinHandle -> FastString -> IO ()) + -> WriterUserData +newWriteState put_non_binding_name put_binding_name put_fs = + mkWriterUserData + [ mkSomeBinaryWriter $ mkWriter (\bh name -> put_binding_name bh (getBindingName name)) + , mkSomeBinaryWriter $ mkWriter put_non_binding_name + , mkSomeBinaryWriter $ mkWriter put_fs + ] + +-- ---------------------------------------------------------------------------- +-- Types for lookup and deduplication tables. +-- ---------------------------------------------------------------------------- + +-- | A 'ReaderTable' describes how to deserialise a table from disk, +-- and how to create a 'BinaryReader' that looks up values in the deduplication table. +data ReaderTable a = ReaderTable + { getTable :: ReadBinHandle -> IO (SymbolTable a) + -- ^ Deserialise a list of elements into a 'SymbolTable'. + , mkReaderFromTable :: SymbolTable a -> BinaryReader a + -- ^ Given the table from 'getTable', create a 'BinaryReader' + -- that reads values only from the 'SymbolTable'. + } + +-- | A 'WriterTable' is an interface any deduplication table can implement to +-- describe how the table can be written to disk. +newtype WriterTable = WriterTable + { putTable :: WriteBinHandle -> IO Int + -- ^ Serialise a table to disk. Returns the number of written elements. + } + +-- ---------------------------------------------------------------------------- +-- Common data structures for constructing and maintaining lookup tables for +-- binary serialisation and deserialisation. +-- ---------------------------------------------------------------------------- + +-- | The 'GenericSymbolTable' stores a mapping from already seen elements to an index. +-- If an element wasn't seen before, it is added to the mapping together with a fresh +-- index. +-- +-- 'GenericSymbolTable' is a variant of a 'BinSymbolTable' that is polymorphic in the table implementation. +-- As such it can be used with any container that implements the 'TrieMap' type class. +-- +-- While 'GenericSymbolTable' is similar to the 'BinSymbolTable', it supports storing tree-like +-- structures such as 'Type' and 'IfaceType' more efficiently. +-- +data GenericSymbolTable m = GenericSymbolTable + { gen_symtab_next :: !FastMutInt + -- ^ The next index to use. + , gen_symtab_map :: !(IORef (m Int)) + -- ^ Given a symbol, find the symbol and return its index. + , gen_symtab_to_write :: !(IORef [Key m]) + -- ^ Reversed list of values to write into the buffer. + -- This is an optimisation, as it allows us to write out quickly all + -- newly discovered values that are discovered when serialising 'Key m' + -- to disk. + } + +-- | Initialise a 'GenericSymbolTable', initialising the index to '0'. +initGenericSymbolTable :: TrieMap m => IO (GenericSymbolTable m) +initGenericSymbolTable = do + symtab_next <- newFastMutInt 0 + symtab_map <- newIORef emptyTM + symtab_todo <- newIORef [] + pure $ GenericSymbolTable + { gen_symtab_next = symtab_next + , gen_symtab_map = symtab_map + , gen_symtab_to_write = symtab_todo + } + +-- | Serialise the 'GenericSymbolTable' to disk. +-- +-- Since 'GenericSymbolTable' stores tree-like structures, such as 'IfaceType', +-- serialising an element can add new elements to the mapping. +-- Thus, 'putGenericSymbolTable' first serialises all values, and then checks whether any +-- new elements have been discovered. If so, repeat the loop. +putGenericSymbolTable :: forall m. (TrieMap m) => GenericSymbolTable m -> (WriteBinHandle -> Key m -> IO ()) -> WriteBinHandle -> IO Int +{-# INLINE putGenericSymbolTable #-} +putGenericSymbolTable gen_sym_tab serialiser bh = do + putGenericSymbolTable bh + where + symtab_next = gen_symtab_next gen_sym_tab + symtab_to_write = gen_symtab_to_write gen_sym_tab + putGenericSymbolTable :: WriteBinHandle -> IO Int + putGenericSymbolTable bh = do + let loop = do + vs <- atomicModifyIORef' symtab_to_write (\a -> ([], a)) + case vs of + [] -> readFastMutInt symtab_next + todo -> do + mapM_ (\n -> serialiser bh n) (reverse todo) + loop + snd <$> + (forwardPutRel bh (const $ readFastMutInt symtab_next >>= put_ bh) $ + loop) + +-- | Read the elements of a 'GenericSymbolTable' from disk into a 'SymbolTable'. +getGenericSymbolTable :: forall a . (ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a) +getGenericSymbolTable deserialiser bh = do + sz <- forwardGetRel bh (get bh) :: IO Int + mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a) + forM_ [0..(sz-1)] $ \i -> do + f <- deserialiser bh + writeArray mut_arr i f + unsafeFreeze mut_arr + +-- | Write an element 'Key m' to the given 'WriteBinHandle'. +-- +-- If the element was seen before, we simply write the index of that element to the +-- 'WriteBinHandle'. If we haven't seen it before, we add the element to +-- the 'GenericSymbolTable', increment the index, and return this new index. +putGenericSymTab :: (TrieMap m) => GenericSymbolTable m -> WriteBinHandle -> Key m -> IO () +{-# INLINE putGenericSymTab #-} +putGenericSymTab GenericSymbolTable{ + gen_symtab_map = symtab_map_ref, + gen_symtab_next = symtab_next, + gen_symtab_to_write = symtab_todo } + bh val = do + symtab_map <- readIORef symtab_map_ref + case lookupTM val symtab_map of + Just off -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! insertTM val off symtab_map + atomicModifyIORef symtab_todo (\todo -> (val : todo, ())) + put_ bh (fromIntegral off :: Word32) + +-- | Read a value from a 'SymbolTable'. +getGenericSymtab :: Binary a => SymbolTable a -> ReadBinHandle -> IO a +getGenericSymtab symtab bh = do + i :: Word32 <- get bh + return $! symtab ! fromIntegral i + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +-- | A 'SymbolTable' of 'FastString's. +type Dictionary = SymbolTable FastString + +initFastStringReaderTable :: IO (ReaderTable FastString) +initFastStringReaderTable = do + return $ + ReaderTable + { getTable = getDictionary + , mkReaderFromTable = \tbl -> mkReader (getDictFastString tbl) + } + +initFastStringWriterTable :: IO (WriterTable, BinaryWriter FastString) +initFastStringWriterTable = do + dict_next_ref <- newFastMutInt 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = + FSTable + { fs_tab_next = dict_next_ref + , fs_tab_map = dict_map_ref + } + let put_dict bh = do + fs_count <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh fs_count dict_map + pure fs_count + + return + ( WriterTable + { putTable = put_dict + } + , mkWriter $ putDictFastString bin_dict + ) + +putDictionary :: WriteBinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO () +putDictionary bh sz dict = do + put_ bh sz + mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) + -- It's OK to use nonDetEltsUFM here because the elements have indices + -- that array uses to create order + +getDictionary :: ReadBinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh :: IO Int + mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString) + forM_ [0..(sz-1)] $ \i -> do + fs <- getFS bh + writeArray mut_arr i fs + unsafeFreeze mut_arr + +getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString +getDictFastString dict bh = do + j <- get bh + return $! (dict ! fromIntegral (j :: Word32)) + +putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO () +putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh + +allocateFastString :: FSTable -> FastString -> IO Word32 +allocateFastString FSTable { fs_tab_next = j_r + , fs_tab_map = out_r + } f = do + out <- readIORef out_r + let !uniq = getUnique f + case lookupUFM_Directly out uniq of + Just (j, _) -> return (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM_Directly out uniq (j, f) + return (fromIntegral j :: Word32) + +-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to +-- avoid a collision and copy to avoid a dependency. +data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use + , fs_tab_map :: !(IORef (UniqFM FastString (Int,FastString))) + -- indexed by FastString + } + + +--------------------------------------------------------- +-- The Symbol Table +--------------------------------------------------------- + +-- | Symbols that are read from disk. +-- The 'SymbolTable' index starts on '0'. +type SymbolTable a = Array Int a + +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + +putFS :: WriteBinHandle -> FastString -> IO () +putFS bh fs = putBS bh $ bytesFS fs + +getFS :: ReadBinHandle -> IO FastString +getFS bh = do + l <- get bh :: IO Int + getPrim bh l (\src -> pure $! mkFastStringBytes src l ) + +-- | Put a ByteString without its length (can't be read back without knowing the +-- length!) +putByteString :: WriteBinHandle -> ByteString -> IO () +putByteString bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + putPrim bh l (\op -> copyBytes op (castPtr ptr) l) + +-- | Get a ByteString whose length is known +getByteString :: ReadBinHandle -> Int -> IO ByteString +getByteString bh l = + BS.create l $ \dest -> do + getPrim bh l (\src -> copyBytes dest src l) + +putBS :: WriteBinHandle -> ByteString -> IO () +putBS bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + put_ bh l + putPrim bh l (\op -> copyBytes op (castPtr ptr) l) + +getBS :: ReadBinHandle -> IO ByteString +getBS bh = do + l <- get bh :: IO Int + BS.create l $ \dest -> do + getPrim bh l (\src -> copyBytes dest src l) + +instance Binary ByteString where + put_ bh f = putBS bh f + get bh = getBS bh + +instance Binary FastString where + put_ bh f = + case findUserDataWriter (Proxy :: Proxy FastString) bh of + tbl -> putEntry tbl bh f + + get bh = + case findUserDataReader (Proxy :: Proxy FastString) bh of + tbl -> getEntry tbl bh + +deriving instance Binary NonDetFastString +deriving instance Binary LexicalFastString + +instance Binary Fingerprint where + put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 + get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) + +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + +-- instance Binary TupleSort where +-- put_ bh BoxedTuple = putByte bh 0 +-- put_ bh UnboxedTuple = putByte bh 1 +-- put_ bh ConstraintTuple = putByte bh 2 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return BoxedTuple +-- 1 -> do return UnboxedTuple +-- _ -> do return ConstraintTuple + +-- instance Binary Activation where +-- put_ bh NeverActive = do +-- putByte bh 0 +-- put_ bh FinalActive = do +-- putByte bh 1 +-- put_ bh AlwaysActive = do +-- putByte bh 2 +-- put_ bh (ActiveBefore src aa) = do +-- putByte bh 3 +-- put_ bh src +-- put_ bh aa +-- put_ bh (ActiveAfter src ab) = do +-- putByte bh 4 +-- put_ bh src +-- put_ bh ab +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return NeverActive +-- 1 -> do return FinalActive +-- 2 -> do return AlwaysActive +-- 3 -> do src <- get bh +-- aa <- get bh +-- return (ActiveBefore src aa) +-- _ -> do src <- get bh +-- ab <- get bh +-- return (ActiveAfter src ab) + +-- instance Binary InlinePragma where +-- put_ bh (InlinePragma s a b c d) = do +-- put_ bh s +-- put_ bh a +-- put_ bh b +-- put_ bh c +-- put_ bh d + +-- get bh = do +-- s <- get bh +-- a <- get bh +-- b <- get bh +-- c <- get bh +-- d <- get bh +-- return (InlinePragma s a b c d) + +-- instance Binary RuleMatchInfo where +-- put_ bh FunLike = putByte bh 0 +-- put_ bh ConLike = putByte bh 1 +-- get bh = do +-- h <- getByte bh +-- if h == 1 then return ConLike +-- else return FunLike + +-- instance Binary InlineSpec where +-- put_ bh NoUserInlinePrag = putByte bh 0 +-- put_ bh Inline = putByte bh 1 +-- put_ bh Inlinable = putByte bh 2 +-- put_ bh NoInline = putByte bh 3 + +-- get bh = do h <- getByte bh +-- case h of +-- 0 -> return NoUserInlinePrag +-- 1 -> return Inline +-- 2 -> return Inlinable +-- _ -> return NoInline + +-- instance Binary RecFlag where +-- put_ bh Recursive = do +-- putByte bh 0 +-- put_ bh NonRecursive = do +-- putByte bh 1 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return Recursive +-- _ -> do return NonRecursive + +-- instance Binary OverlapMode where +-- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s +-- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s +-- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s +-- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s +-- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> (get bh) >>= \s -> return $ NoOverlap s +-- 1 -> (get bh) >>= \s -> return $ Overlaps s +-- 2 -> (get bh) >>= \s -> return $ Incoherent s +-- 3 -> (get bh) >>= \s -> return $ Overlapping s +-- 4 -> (get bh) >>= \s -> return $ Overlappable s +-- _ -> panic ("get OverlapMode" ++ show h) + + +-- instance Binary OverlapFlag where +-- put_ bh flag = do put_ bh (overlapMode flag) +-- put_ bh (isSafeOverlap flag) +-- get bh = do +-- h <- get bh +-- b <- get bh +-- return OverlapFlag { overlapMode = h, isSafeOverlap = b } + +-- instance Binary FixityDirection where +-- put_ bh InfixL = do +-- putByte bh 0 +-- put_ bh InfixR = do +-- putByte bh 1 +-- put_ bh InfixN = do +-- putByte bh 2 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return InfixL +-- 1 -> do return InfixR +-- _ -> do return InfixN + +-- instance Binary Fixity where +-- put_ bh (Fixity src aa ab) = do +-- put_ bh src +-- put_ bh aa +-- put_ bh ab +-- get bh = do +-- src <- get bh +-- aa <- get bh +-- ab <- get bh +-- return (Fixity src aa ab) + +-- instance Binary WarningTxt where +-- put_ bh (WarningTxt s w) = do +-- putByte bh 0 +-- put_ bh s +-- put_ bh w +-- put_ bh (DeprecatedTxt s d) = do +-- putByte bh 1 +-- put_ bh s +-- put_ bh d + +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do s <- get bh +-- w <- get bh +-- return (WarningTxt s w) +-- _ -> do s <- get bh +-- d <- get bh +-- return (DeprecatedTxt s d) + +-- instance Binary StringLiteral where +-- put_ bh (StringLiteral st fs _) = do +-- put_ bh st +-- put_ bh fs +-- get bh = do +-- st <- get bh +-- fs <- get bh +-- return (StringLiteral st fs Nothing) + +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 <- unBinSrcSpan <$> get bh + x <- get bh + return $ BinLocated (L l x) + +newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan } + +-- 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) + put_ bh (srcSpanEndLine ss) + put_ bh (srcSpanEndCol ss) + + get bh = do + f <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) + +instance Binary UnhelpfulSpanReason where + put_ bh r = case r of + UnhelpfulNoLocationInfo -> putByte bh 0 + UnhelpfulWiredIn -> putByte bh 1 + UnhelpfulInteractive -> putByte bh 2 + UnhelpfulGenerated -> putByte bh 3 + UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs + + get bh = do + h <- getByte bh + case h of + 0 -> return UnhelpfulNoLocationInfo + 1 -> return UnhelpfulWiredIn + 2 -> return UnhelpfulInteractive + 3 -> return UnhelpfulGenerated + _ -> UnhelpfulOther <$> get bh + +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 $ BinSpan ss + + put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> do BinSpan ss <- get bh + return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) + _ -> do s <- get bh + 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 +-------------------------------------------------------------------------------- + +instance (Binary v) => Binary (IntMap v) where + put_ bh m = put_ bh (IntMap.toList m) + get bh = IntMap.fromList <$> get bh diff --git a/src/GHC/Iface/Ext/Compat.hs b/src/GHC/Iface/Ext/Compat.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Iface/Ext/Compat.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +module GHC.Iface.Ext.Compat where + +#if !MIN_VERSION_ghc(9,12,1) +mkIfLclName :: a -> a +mkIfLclName = id +#endif diff --git a/src/GHC/Iface/Ext/Debug.hs b/src/GHC/Iface/Ext/Debug.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Iface/Ext/Debug.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -w #-} + +{- +Functions to validate and check .hie file ASTs generated by GHC. +-} + +module GHC.Iface.Ext.Debug where + +import GHC.Prelude + +import GHC.Types.SrcLoc +import GHC.Unit.Module +import GHC.Utils.Outputable + +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils +import GHC.Types.Name + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Function ( on ) +import Data.List ( sortOn ) + +type Diff a = a -> a -> [SDoc] + +diffFile :: Diff HieFile +diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) + +diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map HiePath (HieAST a)) +diffAsts f = diffList (diffAst f) `on` M.elems + +diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a) +diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) = + infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2 + where + spanDiff + | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]] + | otherwise = [] + infoDiff' i1 i2 + = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2 + ++ (diffList diffType `on` nodeType) i1 i2 + ++ (diffIdents `on` nodeIdentifiers) i1 i2 + sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo) + infoDiff = case sinfoDiff info1 info2 of + [] -> [] + xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1) + , "and", ppr (sourcedNodeIdents info2,span2) + , "While comparing" + , ppr (normalizeIdents $ sourcedNodeIdents info1), "and" + , ppr (normalizeIdents $ sourcedNodeIdents info2) + ] + ] + + diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b + diffIdent (a,b) (c,d) = diffName a c + ++ eqDiff b d + diffName (Right a) (Right b) = case (a,b) of + (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o') + (LocalName o _, ExternalName _ o' _) -> eqDiff o o' + _ -> eqDiff a b + diffName a b = eqDiff a b + +type DiffIdent = Either ModuleName HieName + +normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)] +normalizeIdents = sortOn go . map (first toHieName) . M.toList + where + first f (a,b) = (fmap f a, b) + go (a,b) = (hieNameOcc <$> a,identInfo b,identType b) + +diffList :: Diff a -> Diff [a] +diffList f xs ys + | length xs == length ys = concat $ zipWith f xs ys + | otherwise = ["length of lists doesn't match"] + +eqDiff :: (Outputable a, Eq a) => Diff a +eqDiff a b + | a == b = [] + | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]] + +validAst :: HieAST a -> Either SDoc () +validAst (Node _ span children) = do + checkContainment children + checkSorted children + mapM_ validAst children + where + checkSorted [] = return () + checkSorted [_] = return () + checkSorted (x:y:xs) + | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs) + | otherwise = Left $ hsep + [ ppr $ nodeSpan x + , "is not to the left of" + , ppr $ nodeSpan y + ] + checkContainment [] = return () + checkContainment (x:xs) + | span `containsSpan` (nodeSpan x) = checkContainment xs + | otherwise = Left $ hsep + [ ppr $ span + , "does not contain" + , ppr $ nodeSpan x + ] + +-- | Look for any identifiers which occur outside of their supposed scopes. +-- Returns a list of error messages. +validateScopes :: Module -> M.Map HiePath (HieAST a) -> [SDoc] +validateScopes mod asts = validScopes ++ validEvs + where + refMap = generateReferencesMap asts + -- We use a refmap for most of the computation + + evs = M.keys + $ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap + + validEvs = do + i@(Right ev) <- evs + case M.lookup i refMap of + Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ] + Just refs + | nameIsLocalOrFrom mod ev + , not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs) + -> ["Evidence var" <+> ppr ev <+> "not bound in refmap"] + | otherwise -> [] + + -- Check if all the names occur in their calculated scopes + validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap + valid (Left _) _ = [] + valid (Right n) refs = concatMap inScope refs + where + mapRef = foldMap getScopeFromContext . identInfo . snd + scopes = case foldMap mapRef refs of + Just xs -> xs + Nothing -> [] + inScope (sp, dets) + | (definedInAsts asts n || (any isEvidenceContext (identInfo dets))) + && any isOccurrence (identInfo dets) + -- We validate scopes for names which are defined locally, and occur + -- in this span, or are evidence variables + = case scopes of + [] | nameIsLocalOrFrom mod n + , ( not (isDerivedOccName $ nameOccName n) + || any isEvidenceContext (identInfo dets)) + -- If we don't get any scopes for a local name or + -- an evidence variable, then its an error. + -- We can ignore other kinds of derived names as + -- long as we take evidence vars into account + -> return $ hsep $ + [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp + , "Doesn't have a calculated scope: ", ppr scopes] + | otherwise -> [] + _ -> if any (`scopeContainsSpan` sp) scopes + then [] + else return $ hsep $ + [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp + , "doesn't occur in calculated scope", ppr scopes] + | otherwise = [] diff --git a/src/GHC/Iface/Ext/Types.hs b/src/GHC/Iface/Ext/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Iface/Ext/Types.hs @@ -0,0 +1,865 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -w #-} + +{- +Types for the .hie file format are defined here. + +For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files +-} + +module GHC.Iface.Ext.Types where + +import GHC.Prelude + +import GHC.Settings.Config +import GHC.Iface.Ext.Binary.Utils +import GHC.Iface.Ext.Binary.Instances () +import GHC.Data.FastString +import GHC.Builtin.Utils +import GHC.Iface.Type +import GHC.Unit.Module ( ModuleName, Module ) +import GHC.Types.Name +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Types.SrcLoc +import GHC.Types.Avail +import GHC.Types.Unique +import qualified GHC.Utils.Outputable as O ( (<>) ) +import GHC.Utils.Panic +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.TyCo.Rep ( Type(..) ) +import GHC.Core.Type ( coreFullView, isFunTy, Var (..) ) +import GHC.Core.TyCon ( isTypeSynonymTyCon, isClassTyCon, isFamilyTyCon ) +import GHC.Types.Id ( Id, isRecordSelector, isClassOpId ) +import GHC.Types.TyThing ( TyThing (..) ) +import GHC.Types.Var ( isTyVar, isFUNArg ) + +import qualified Data.Array as A +import qualified Data.Map as M +import qualified Data.Set as S +import Data.ByteString ( ByteString ) +import Data.Data ( Data ) +import Data.Semigroup ( Semigroup(..) ) +import Data.Word ( Word8 ) +import Control.Applicative ( (<|>) ) +import Data.Coerce ( coerce ) +import Data.Function ( on ) +import qualified Data.Semigroup as S + +type Span = RealSrcSpan + +{- | +GHC builds up a wealth of information about Haskell source as it compiles it. +@.hie@ files are a way of persisting some of this information to disk so that +external tools that need to work with haskell source don't need to parse, +typecheck, and rename all over again. These files contain: + + * a simplified AST + + * nodes are annotated with source positions and types + * identifiers are annotated with scope information + + * the raw bytes of the initial Haskell source + +Besides saving compilation cycles, @.hie@ files also offer a more stable +interface than the GHC API. +-} +data HieFile = HieFile + { hie_hs_file :: FilePath + -- ^ Initial Haskell source file path + + , hie_module :: Module + -- ^ The module this HIE file is for + + , hie_types :: A.Array TypeIndex HieTypeFlat + -- ^ Types referenced in the 'hie_asts'. + -- + -- See Note [Efficient serialization of redundant type info] + + , hie_asts :: HieASTs TypeIndex + -- ^ Type-annotated abstract syntax trees + + , hie_exports :: [AvailInfo] + -- ^ The names that this module exports + + , hie_hs_src :: ByteString + -- ^ Raw bytes of the initial Haskell source + + , hie_entity_infos :: NameEntityInfo + -- ^ Entity information for each `Name` in the `hie_asts` + } + +type NameEntityInfo = M.Map Name (S.Set EntityInfo) + +instance Binary NameEntityInfo where + put_ bh m = put_ bh $ M.toList m + get bh = fmap M.fromList (get bh) + + +{- +Note [Efficient serialization of redundant type info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The type information in .hie files is highly repetitive and redundant. For +example, consider the expression + + const True 'a' + +There is a lot of shared structure between the types of subterms: + + * const True 'a' :: Bool + * const True :: Char -> Bool + * const :: Bool -> Char -> Bool + +Since all 3 of these types need to be stored in the .hie file, it is worth +making an effort to deduplicate this shared structure. The trick is to define +a new data type that is a flattened version of 'Type': + + data HieType a = HAppTy a a -- data Type = AppTy Type Type + | HFunTy a a -- | FunTy Type Type + | ... + + type TypeIndex = Int + +Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)', +where the 'TypeIndex's in the 'HieType' are references to other elements of the +array. Types recovered from GHC are deduplicated and stored in this compressed +form with sharing of subtrees. +-} + +type TypeIndex = Int + +-- | A flattened version of 'Type'. +-- +-- See Note [Efficient serialization of redundant type info] +data HieType a + = HTyVarTy Name + | HAppTy a (HieArgs a) + | HTyConApp IfaceTyCon (HieArgs a) + | HForAllTy ((Name, a),ForAllTyFlag) a + | HFunTy a a a + | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') + | HLitTy IfaceTyLit + | HCastTy a + | HCoercionTy + deriving (Functor, Foldable, Traversable, Eq) + +type HieTypeFlat = HieType TypeIndex + +-- | Roughly isomorphic to the original core 'Type'. +newtype HieTypeFix = Roll (HieType (HieTypeFix)) + deriving Eq + +instance Binary (HieType TypeIndex) where + put_ bh (HTyVarTy n) = do + putByte bh 0 + put_ bh n + put_ bh (HAppTy a b) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh (HTyConApp n xs) = do + putByte bh 2 + put_ bh n + put_ bh xs + put_ bh (HForAllTy bndr a) = do + putByte bh 3 + put_ bh bndr + put_ bh a + put_ bh (HFunTy w a b) = do + putByte bh 4 + put_ bh w + put_ bh a + put_ bh b + put_ bh (HQualTy a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (HLitTy l) = do + putByte bh 6 + put_ bh l + put_ bh (HCastTy a) = do + putByte bh 7 + put_ bh a + put_ bh (HCoercionTy) = putByte bh 8 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> HTyVarTy <$> get bh + 1 -> HAppTy <$> get bh <*> get bh + 2 -> HTyConApp <$> get bh <*> get bh + 3 -> HForAllTy <$> get bh <*> get bh + 4 -> HFunTy <$> get bh <*> get bh <*> get bh + 5 -> HQualTy <$> get bh <*> get bh + 6 -> HLitTy <$> get bh + 7 -> HCastTy <$> get bh + 8 -> return HCoercionTy + _ -> panic "Binary (HieArgs Int): invalid tag" + + +-- | A list of type arguments along with their respective visibilities (ie. is +-- this an argument that would return 'True' for 'isVisibleForAllTyFlag'?). +newtype HieArgs a = HieArgs [(Bool,a)] + deriving (Functor, Foldable, Traversable, Eq, Show) + +instance Binary (HieArgs TypeIndex) where + put_ bh (HieArgs xs) = put_ bh xs + get bh = HieArgs <$> get bh + + +-- A HiePath is just a lexical FastString. We use a lexical FastString to avoid +-- non-determinism when printing or storing HieASTs which are sorted by their +-- HiePath. +type HiePath = LexicalFastString + +{-# COMPLETE HiePath #-} +pattern HiePath :: FastString -> HiePath +pattern HiePath fs = LexicalFastString fs + +-- | Mapping from filepaths to the corresponding AST +newtype HieASTs a = HieASTs { getAsts :: M.Map HiePath (HieAST a) } + deriving (Functor, Foldable, Traversable, Eq) + +instance Binary (HieASTs TypeIndex) where + put_ bh asts = put_ bh $ M.toAscList $ getAsts asts + get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh) + +instance Outputable a => Outputable (HieASTs a) where + ppr (HieASTs asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "File: " O.<> ppr k + , ppr a + , rest + ] + +data HieAST a = + Node + { sourcedNodeInfo :: SourcedNodeInfo a + , nodeSpan :: Span + , nodeChildren :: [HieAST a] + } deriving (Functor, Foldable, Traversable, Eq) + +instance Binary (HieAST TypeIndex) where + put_ bh ast = do + put_ bh $ sourcedNodeInfo ast + put_ bh $ BinSpan $ nodeSpan ast + put_ bh $ nodeChildren ast + + get bh = Node + <$> get bh + <*> (unBinSpan <$> get bh) + <*> get bh + +instance Outputable a => Outputable (HieAST a) where + ppr (Node ni sp ch) = hang header 2 rest + where + header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni + rest = vcat (map ppr ch) + + +-- | NodeInfos grouped by source +newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) } + deriving (Functor, Foldable, Traversable, Eq) + +instance Binary (SourcedNodeInfo TypeIndex) where + put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts + get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh) + +instance Outputable a => Outputable (SourcedNodeInfo a) where + ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "Source: " O.<> ppr k + , ppr a + , rest + ] + +-- | Source of node info +data NodeOrigin + = SourceInfo + | GeneratedInfo + deriving (Eq, Enum, Ord) + +instance Outputable NodeOrigin where + ppr SourceInfo = text "From source" + ppr GeneratedInfo = text "generated by ghc" + +instance Binary NodeOrigin where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + +-- | A node annotation +data NodeAnnotation = NodeAnnotation + { nodeAnnotConstr :: !FastString -- ^ name of the AST node constructor + , nodeAnnotType :: !FastString -- ^ name of the AST node Type + } + deriving (Eq) + +instance Ord NodeAnnotation where + compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1) + = mconcat [lexicalCompareFS c0 c1, lexicalCompareFS t0 t1] + +instance Outputable NodeAnnotation where + ppr (NodeAnnotation c t) = ppr (c,t) + +instance Binary NodeAnnotation where + put_ bh (NodeAnnotation c t) = do + put_ bh c + put_ bh t + get bh = NodeAnnotation + <$> get bh + <*> get bh + +-- | The information stored in one AST node. +-- +-- The type parameter exists to provide flexibility in representation of types +-- (see Note [Efficient serialization of redundant type info]). +data NodeInfo a = NodeInfo + { nodeAnnotations :: S.Set NodeAnnotation + -- ^ Annotations + + , nodeType :: [a] + -- ^ The Haskell types of this node, if any. + + , nodeIdentifiers :: NodeIdentifiers a + -- ^ All the identifiers and their details + } deriving (Functor, Foldable, Traversable, Eq) + +instance Binary (NodeInfo TypeIndex) where + put_ bh ni = do + put_ bh $ S.toAscList $ nodeAnnotations ni + put_ bh $ nodeType ni + put_ bh $ M.toList $ nodeIdentifiers ni + get bh = NodeInfo + <$> fmap (S.fromDistinctAscList) (get bh) + <*> get bh + <*> fmap (M.fromList) (get bh) + +instance Outputable a => Outputable (NodeInfo a) where + ppr (NodeInfo anns typs idents) = braces $ fsep $ punctuate ", " + [ parens (text "annotations:" <+> ppr anns) + , parens (text "types:" <+> ppr typs) + , parens (text "identifier info:" <+> pprNodeIdents idents) + ] + +pprNodeIdents :: Outputable a => NodeIdentifiers a -> SDoc +pprNodeIdents ni = braces $ fsep $ punctuate ", " $ map go $ M.toList ni + where + go (i,id) = parens $ hsep $ punctuate ", " [pprIdentifier i, ppr id] + +pprIdentifier :: Identifier -> SDoc +pprIdentifier (Left mod) = text "module" <+> ppr mod +pprIdentifier (Right name) = text "name" <+> ppr name + +type Identifier = Either ModuleName Name + +type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a) + +-- | Information associated with every identifier +-- +-- We need to include types with identifiers because sometimes multiple +-- identifiers occur in the same span(Overloaded Record Fields and so on) +data IdentifierDetails a = IdentifierDetails + { identType :: Maybe a + , identInfo :: S.Set ContextInfo + } deriving (Eq, Functor, Foldable, Traversable) + +instance Outputable a => Outputable (IdentifierDetails a) where + ppr x = text "Details: " <+> ppr (identType x) <+> ppr (identInfo x) + +instance Semigroup (IdentifierDetails a) where + d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2) + (S.union (identInfo d1) (identInfo d2)) + +instance Monoid (IdentifierDetails a) where + mempty = IdentifierDetails Nothing S.empty + +instance Binary (IdentifierDetails TypeIndex) where + put_ bh dets = do + put_ bh $ identType dets + put_ bh $ S.toList $ identInfo dets + get bh = IdentifierDetails + <$> get bh + <*> fmap S.fromDistinctAscList (get bh) + + +-- | Different contexts under which identifiers exist +data ContextInfo + = Use -- ^ regular variable + | MatchBind + | IEThing IEType -- ^ import/export + | TyDecl + + -- | Value binding + | ValBind + BindType -- ^ whether or not the binding is in an instance + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of entire binding + + -- | Pattern binding + -- + -- This case is tricky because the bound identifier can be used in two + -- distinct scopes. Consider the following example (with @-XViewPatterns@) + -- + -- @ + -- do (b, a, (a -> True)) <- bar + -- foo a + -- @ + -- + -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and + -- in the rest of the @do@-block in @foo a@. + | PatternBind + Scope -- ^ scope /in the pattern/ (the variable bound can be used + -- further in the pattern) + Scope -- ^ rest of the scope outside the pattern + (Maybe Span) -- ^ span of entire binding + + | ClassTyDecl (Maybe Span) + + -- | Declaration + | Decl + DeclType -- ^ type of declaration + (Maybe Span) -- ^ span of entire binding + + -- | Type variable + | TyVarBind Scope TyVarScope + + -- | Record field + | RecField RecFieldContext (Maybe Span) + -- | Constraint/Dictionary evidence variable binding + | EvidenceVarBind + EvVarSource -- ^ how did this bind come into being + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of the binding site + + -- | Usage of evidence variable + | EvidenceVarUse + deriving (Eq, Ord) + +instance Outputable ContextInfo where + ppr (Use) = text "usage" + ppr (MatchBind) = text "LHS of a match group" + ppr (IEThing x) = ppr x + ppr (TyDecl) = text "bound in a type signature declaration" + ppr (ValBind t sc sp) = + ppr t <+> text "value bound with scope:" <+> ppr sc <+> pprBindSpan sp + ppr (PatternBind sc1 sc2 sp) = + text "bound in a pattern with scope:" + <+> ppr sc1 <+> "," <+> ppr sc2 + <+> pprBindSpan sp + ppr (ClassTyDecl sp) = + text "bound in a class type declaration" <+> pprBindSpan sp + ppr (Decl d sp) = + text "declaration of" <+> ppr d <+> pprBindSpan sp + ppr (TyVarBind sc1 sc2) = + text "type variable binding with scope:" + <+> ppr sc1 <+> "," <+> ppr sc2 + ppr (RecField ctx sp) = + text "record field" <+> ppr ctx <+> pprBindSpan sp + ppr (EvidenceVarBind ctx sc sp) = + text "evidence variable" <+> ppr ctx + $$ "with scope:" <+> ppr sc + $$ pprBindSpan sp + ppr (EvidenceVarUse) = + text "usage of evidence variable" + +pprBindSpan :: Maybe Span -> SDoc +pprBindSpan Nothing = text "" +pprBindSpan (Just sp) = text "bound at:" <+> ppr sp + +instance Binary ContextInfo where + put_ bh Use = putByte bh 0 + put_ bh (IEThing t) = do + putByte bh 1 + put_ bh t + put_ bh TyDecl = putByte bh 2 + put_ bh (ValBind bt sc msp) = do + putByte bh 3 + put_ bh bt + put_ bh sc + put_ bh $ BinSpan <$> msp + put_ bh (PatternBind a b c) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh $ BinSpan <$> c + put_ bh (ClassTyDecl sp) = do + putByte bh 5 + put_ bh $ BinSpan <$> sp + put_ bh (Decl a b) = do + putByte bh 6 + put_ bh a + put_ bh $ BinSpan <$> b + put_ bh (TyVarBind a b) = do + putByte bh 7 + put_ bh a + put_ bh b + put_ bh (RecField a b) = do + putByte bh 8 + put_ bh a + 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 $ BinSpan <$> c + put_ bh EvidenceVarUse = putByte bh 11 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> return Use + 1 -> IEThing <$> get bh + 2 -> return TyDecl + 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 <*> (fmap unBinSpan <$> get bh) + 9 -> return MatchBind + 10 -> EvidenceVarBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) + 11 -> return EvidenceVarUse + _ -> panic "Binary ContextInfo: invalid tag" + +data EvVarSource + = EvPatternBind -- ^ bound by a pattern match + | EvSigBind -- ^ bound by a type signature + | EvWrapperBind -- ^ bound by a hswrapper + | EvImplicitBind -- ^ bound by an implicit variable + | EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class + | EvLetBind EvBindDeps -- ^ A direct let binding + deriving (Eq,Ord) + +instance Binary EvVarSource where + put_ bh EvPatternBind = putByte bh 0 + put_ bh EvSigBind = putByte bh 1 + put_ bh EvWrapperBind = putByte bh 2 + put_ bh EvImplicitBind = putByte bh 3 + put_ bh (EvInstBind b cls) = do + putByte bh 4 + put_ bh b + put_ bh cls + put_ bh (EvLetBind deps) = do + putByte bh 5 + put_ bh deps + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> pure EvPatternBind + 1 -> pure EvSigBind + 2 -> pure EvWrapperBind + 3 -> pure EvImplicitBind + 4 -> EvInstBind <$> get bh <*> get bh + 5 -> EvLetBind <$> get bh + _ -> panic "Binary EvVarSource: invalid tag" + +instance Outputable EvVarSource where + ppr EvPatternBind = text "bound by a pattern" + ppr EvSigBind = text "bound by a type signature" + ppr EvWrapperBind = text "bound by a HsWrapper" + ppr EvImplicitBind = text "bound by an implicit variable binding" + ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls + ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls + ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps + +-- | Eq/Ord instances compare on the converted HieName, +-- as non-exported names may have different uniques after +-- a roundtrip +newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] } + deriving Outputable + +instance Eq EvBindDeps where + (==) = coerce ((==) `on` map toHieName) + +instance Ord EvBindDeps where + compare = coerce (compare `on` map toHieName) + +instance Binary EvBindDeps where + put_ bh (EvBindDeps xs) = put_ bh xs + get bh = EvBindDeps <$> get bh + + +-- | Types of imports and exports +data IEType + = Import + | ImportAs + | ImportHiding + | Export + deriving (Eq, Enum, Ord) + +instance Outputable IEType where + ppr Import = text "import" + ppr ImportAs = text "import as" + ppr ImportHiding = text "import hiding" + ppr Export = text "export" + +instance Binary IEType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data RecFieldContext + = RecFieldDecl + | RecFieldAssign + | RecFieldMatch + | RecFieldOcc + deriving (Eq, Enum, Ord) + +instance Outputable RecFieldContext where + ppr RecFieldDecl = text "declaration" + ppr RecFieldAssign = text "assignment" + ppr RecFieldMatch = text "pattern match" + ppr RecFieldOcc = text "occurrence" + +instance Binary RecFieldContext where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data BindType + = RegularBind + | InstanceBind + deriving (Eq, Ord, Enum) + +instance Outputable BindType where + ppr RegularBind = "regular" + ppr InstanceBind = "instance" + +instance Binary BindType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + +data DeclType + = FamDec -- ^ type or data family + | SynDec -- ^ type synonym + | DataDec -- ^ data declaration + | ConDec -- ^ constructor declaration + | PatSynDec -- ^ pattern synonym + | ClassDec -- ^ class declaration + | InstDec -- ^ instance declaration + deriving (Eq, Ord, Enum) + +instance Outputable DeclType where + ppr FamDec = text "type or data family" + ppr SynDec = text "type synonym" + ppr DataDec = text "data" + ppr ConDec = text "constructor" + ppr PatSynDec = text "pattern synonym" + ppr ClassDec = text "class" + ppr InstDec = text "instance" + +instance Binary DeclType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + +data Scope + = NoScope + | LocalScope Span + | ModuleScope + deriving (Eq, Ord, Data) + +instance Outputable Scope where + ppr NoScope = text "NoScope" + ppr (LocalScope sp) = text "LocalScope" <+> ppr sp + ppr ModuleScope = text "ModuleScope" + +instance Binary Scope where + put_ bh NoScope = putByte bh 0 + put_ bh (LocalScope span) = do + putByte bh 1 + 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 . unBinSpan <$> get bh + 2 -> return ModuleScope + _ -> panic "Binary Scope: invalid tag" + + +-- | Scope of a type variable. +-- +-- This warrants a data type apart from 'Scope' because of complexities +-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For +-- example, consider: +-- +-- @ +-- foo, bar, baz :: forall a. a -> a +-- @ +-- +-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we +-- need a list of scopes to keep track of this. Furthermore, this list cannot be +-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@. +-- +-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@ +-- which later gets resolved into a 'ResolvedScopes'. +data TyVarScope + = ResolvedScopes [Scope] + + -- | Unresolved scopes should never show up in the final @.hie@ file + | UnresolvedScope + [Name] -- ^ names of the definitions over which the scope spans + (Maybe Span) -- ^ the location of the instance/class declaration for + -- the case where the type variable is declared in a + -- method type signature + deriving (Eq, Ord) + +instance Outputable TyVarScope where + ppr (ResolvedScopes xs) = + text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs) + ppr (UnresolvedScope ns sp) = + text "unresolved type variable scope for name" O.<> plural ns + <+> pprBindSpan sp + +instance Binary TyVarScope where + put_ bh (ResolvedScopes xs) = do + putByte bh 0 + put_ bh xs + put_ bh (UnresolvedScope ns span) = do + putByte bh 1 + put_ bh ns + put_ bh (BinSpan <$> span) + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> ResolvedScopes <$> 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@ +-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between +-- these two types. +data HieName + = ExternalName !Module !OccName !SrcSpan + | LocalName !OccName !SrcSpan + | KnownKeyName !Unique + deriving (Eq) + +instance Ord HieName where + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) S.<> leftmost_smallest c f + -- TODO (int-index): Perhaps use RealSrcSpan in HieName? + compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d + -- TODO (int-index): Perhaps use RealSrcSpan in HieName? + compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b + -- Not actually non deterministic as it is a KnownKey + compare ExternalName{} _ = LT + compare LocalName{} ExternalName{} = GT + compare LocalName{} _ = LT + compare KnownKeyName{} _ = GT + +instance Outputable HieName where + ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp + ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp + ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u + +hieNameOcc :: HieName -> OccName +hieNameOcc (ExternalName _ occ _) = occ +hieNameOcc (LocalName occ _) = occ +hieNameOcc (KnownKeyName u) = + case lookupKnownKeyName u of + Just n -> nameOccName n + Nothing -> pprPanic "hieNameOcc:unknown known-key unique" + (ppr u) + +toHieName :: Name -> HieName +toHieName name + | isKnownKeyName name = KnownKeyName (nameUnique name) + | isExternalName name = ExternalName (nameModule name) + (nameOccName name) + (removeBufSpan $ nameSrcSpan name) + | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name) + + +{- Note [Capture Entity Information] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to capture the entity information for the identifier in HieAst, so that +language tools and protocols can take advantage making use of it. + +Capture `EntityInfo` for a `Name` or `Id` in `renamedSource` or `typecheckedSource` +if it is a name, we ask the env for the `TyThing` then compute the `EntityInfo` from tyThing +if it is an Id, we compute the `EntityInfo` directly from Id + +see issue #24544 for more details +-} + + +-- | Entity information +-- `EntityInfo` is a simplified version of `TyThing` and richer version than `Namespace` in `OccName`. +-- It state the kind of the entity, such as `Variable`, `TypeVariable`, `DataConstructor`, etc.. +data EntityInfo + = EntityVariable + | EntityFunction + | EntityDataConstructor + | EntityTypeVariable + | EntityClassMethod + | EntityPatternSynonym + | EntityTypeConstructor + | EntityTypeClass + | EntityTypeSynonym + | EntityTypeFamily + | EntityRecordField + deriving (Eq, Ord, Enum, Show) + + +instance Outputable EntityInfo where + ppr EntityVariable = text "variable" + ppr EntityFunction = text "function" + ppr EntityDataConstructor = text "data constructor" + ppr EntityTypeVariable = text "type variable" + ppr EntityClassMethod = text "class method" + ppr EntityPatternSynonym = text "pattern synonym" + ppr EntityTypeConstructor = text "type constructor" + ppr EntityTypeClass = text "type class" + ppr EntityTypeSynonym = text "type synonym" + ppr EntityTypeFamily = text "type family" + ppr EntityRecordField = text "record field" + + +instance Binary EntityInfo where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! toEnum (fromIntegral x) + + +-- | Get the `EntityInfo` for an `Id` +idEntityInfo :: Id -> S.Set EntityInfo +idEntityInfo vid = S.fromList $ [EntityTypeVariable | isTyVar vid] <> [EntityFunction | isFunType $ varType vid] + <> [EntityRecordField | isRecordSelector vid] <> [EntityClassMethod | isClassOpId vid] <> [EntityVariable] + where + isFunType a = case coreFullView a of + ForAllTy _ t -> isFunType t + FunTy { ft_af = flg, ft_res = rhs } -> isFUNArg flg || isFunType rhs + _x -> isFunTy a + +-- | Get the `EntityInfo` for a `TyThing` +tyThingEntityInfo :: TyThing -> S.Set EntityInfo +tyThingEntityInfo ty = case ty of + AnId vid -> idEntityInfo vid + AConLike con -> case con of + RealDataCon _ -> S.singleton EntityDataConstructor + PatSynCon _ -> S.singleton EntityPatternSynonym + ATyCon tyCon -> S.fromList $ [EntityTypeSynonym | isTypeSynonymTyCon tyCon] <> [EntityTypeFamily | isFamilyTyCon tyCon] + <> [EntityTypeClass | isClassTyCon tyCon] <> [EntityTypeConstructor] + ACoAxiom _ -> S.empty + +nameEntityInfo :: Name -> S.Set EntityInfo +nameEntityInfo name + | isTyVarName name = S.fromList [EntityVariable, EntityTypeVariable] + | isDataConName name = S.singleton EntityDataConstructor + | isTcClsNameSpace (occNameSpace $ occName name) = S.singleton EntityTypeConstructor + | isFieldName name = S.fromList [EntityVariable, EntityRecordField] + | isVarName name = S.fromList [EntityVariable] + | otherwise = S.empty diff --git a/src/GHC/Iface/Ext/Utils.hs b/src/GHC/Iface/Ext/Utils.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Iface/Ext/Utils.hs @@ -0,0 +1,605 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -w #-} +module GHC.Iface.Ext.Utils where + +import GHC.Prelude + +import GHC.Core.Map.Type +import GHC.Driver.DynFlags ( DynFlags ) +import GHC.Driver.Ppr +import GHC.Data.FastString ( FastString, mkFastString ) +import GHC.Iface.Type +import GHC.Types.Name hiding (varName) +import GHC.Types.Name.Set +import GHC.Utils.Outputable hiding ( (<>) ) +import qualified GHC.Utils.Outputable as O +import GHC.Types.SrcLoc +import GHC.CoreToIface +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( nonDetCmpType ) +import GHC.Core.Type +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Parser.Annotation +import qualified GHC.Data.Strict as Strict + +import GHC.Iface.Ext.Compat +import GHC.Iface.Ext.Types + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Array as A +import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) ) +import Data.Maybe ( maybeToList, mapMaybe) +import Data.Monoid +import Data.List (find) +import Data.Traversable ( for ) +import Data.Coerce +import GHC.Utils.Monad.State.Strict hiding (get) +import GHC.Utils.Panic.Plain( assert ) +import Control.Monad.Trans.Reader +import qualified Data.Tree as Tree + +type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] + +generateReferencesMap + :: Foldable f + => f (HieAST a) + -> RefMap a +generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty + where + go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) + where + this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast + +renderHieType :: DynFlags -> HieTypeFix -> String +renderHieType dflags ht = showSDoc dflags (ppr $ hieTypeToIface ht) + +resolveVisibility :: Type -> [Type] -> [(Bool,Type)] +resolveVisibility kind ty_args + = go (mkEmptySubst in_scope) kind ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = [] + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (Bndr tv vis) res) (t:ts) + | isVisibleForAllTyFlag vis = (True , t) : ts' + | otherwise = (False, t) : ts' + where + ts' = go (extendTvSubst env tv t) res ts + + go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps + = (True,t) : (go env res ts) + + go env (TyVarTy tv) ts + | Just ki <- lookupTyVar env tv = go env ki ts + go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded + +foldType :: (HieType a -> a) -> HieTypeFix -> a +foldType f (Roll t) = f $ fmap (foldType f) t + +selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int) +selectPoint hf (sl,sc) = getFirst $ + flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(HiePath fs,ast) -> First $ + case selectSmallestContaining (sp fs) ast of + Nothing -> Nothing + Just ast' -> Just ast' + where + sloc fs = mkRealSrcLoc fs sl sc + sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + +findEvidenceUse :: NodeIdentifiers a -> [Name] +findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)] + where + xs = M.toList ni + +data EvidenceInfo a + = EvidenceInfo + { evidenceVar :: Name + , evidenceSpan :: RealSrcSpan + , evidenceType :: a + , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span) + } deriving (Eq, Functor) + +instance Ord a => Ord (EvidenceInfo a) where + compare (EvidenceInfo name span typ dets) (EvidenceInfo name' span' typ' dets') = + case stableNameCmp name name' of + EQ -> compare (span, typ, dets) (span', typ', dets') + r -> r + +instance (Outputable a) => Outputable (EvidenceInfo a) where + ppr (EvidenceInfo name span typ dets) = + hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $ + pdets $$ (pprDefinedAt name) + where + pdets = case dets of + Nothing -> text "is a usage of an external evidence variable" + Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn) + +getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a) +getEvidenceTreesAtPoint hf refmap point = + [t | Just ast <- pure $ selectPoint hf point + , n <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast) + , Just t <- pure $ getEvidenceTree refmap n + ] + +getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a)) +getEvidenceTree refmap var = go emptyNameSet var + where + go seen var + | var `elemNameSet` seen = Nothing + | otherwise = do + xs <- M.lookup (Right var) refmap + case find (any isEvidenceBind . identInfo . snd) xs of + Just (sp,dets) -> do + typ <- identType dets + (evdet,children) <- getFirst $ foldMap First $ do + det <- S.toList $ identInfo dets + case det of + EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn -> + pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs) + EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[]) + _ -> pure Nothing + pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children + -- It is externally bound + Nothing -> getFirst $ foldMap First $ do + (sp,dets) <- xs + if (any isEvidenceUse $ identInfo dets) + then do + case identType dets of + Nothing -> pure Nothing + Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) [] + else pure Nothing + +hieTypeToIface :: HieTypeFix -> IfaceType +hieTypeToIface = foldType go + where + go (HTyVarTy n) = IfaceTyVar $ (mkIfLclName (occNameFS $ getOccName n)) + go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b) + go (HLitTy l) = IfaceLitTy l + go (HForAllTy ((n,k),af) t) = let b = (mkIfLclName (occNameFS $ getOccName n), k) + in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t + go (HFunTy w a b) = IfaceFunTy visArgTypeLike w a b + go (HQualTy pred b) = IfaceFunTy invisArgTypeLike many_ty pred b + go (HCastTy a) = a + go HCoercionTy = IfaceTyVar (mkIfLclName "") + go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) + + -- This isn't fully faithful - we can't produce the 'Inferred' case + hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs + hieToIfaceArgs (HieArgs xs) = go' xs + where + go' [] = IA_Nil + go' ((True ,x):xs) = IA_Arg x Required $ go' xs + go' ((False,x):xs) = IA_Arg x Specified $ go' xs + +data HieTypeState + = HTS + { tyMap :: !(TypeMap TypeIndex) + , htyTable :: !(IM.IntMap HieTypeFlat) + , freshIndex :: !TypeIndex + } + +initialHTS :: HieTypeState +initialHTS = HTS emptyTypeMap IM.empty 0 + +freshTypeIndex :: State HieTypeState TypeIndex +freshTypeIndex = do + index <- gets freshIndex + modify $ \hts -> hts { freshIndex = index+1 } + return index + +compressTypes + :: HieASTs Type + -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +compressTypes asts = (a, arr) + where + (a, (HTS _ m i)) = flip runState initialHTS $ + for asts $ \typ -> + getTypeIndex typ + arr = A.array (0,i-1) (IM.toList m) + +recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix +recoverFullType i m = go i + where + go i = Roll $ fmap go (m A.! i) + +getTypeIndex :: Type -> State HieTypeState TypeIndex +getTypeIndex t + | otherwise = do + tm <- gets tyMap + case lookupTypeMap tm t of + Just i -> return i + Nothing -> do + ht <- go t + extendHTS t ht + where + extendHTS t ht = do + i <- freshTypeIndex + modify $ \(HTS tm tt fi) -> + HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi + return i + + go (TyVarTy v) = return $ HTyVarTy $ varName v + go ty@(AppTy _ _) = do + let (head,args) = splitAppTys ty + visArgs = HieArgs $ resolveVisibility (typeKind head) args + ai <- getTypeIndex head + argsi <- mapM getTypeIndex visArgs + return $ HAppTy ai argsi + go (TyConApp f xs) = do + let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs + is <- mapM getTypeIndex visArgs + return $ HTyConApp (toIfaceTyCon f) is + go (ForAllTy (Bndr v a) t) = do + k <- getTypeIndex (varType v) + i <- getTypeIndex t + return $ HForAllTy ((varName v,k),a) i + go (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) = do + ai <- getTypeIndex a + bi <- getTypeIndex b + wi <- getTypeIndex w + return $ if isInvisibleFunArg af + then assert (isManyTy w) $ HQualTy ai bi + else HFunTy wi ai bi + go (LitTy a) = return $ HLitTy $ toIfaceTyLit a + go (CastTy t _) = do + i <- getTypeIndex t + return $ HCastTy i + go (CoercionTy _) = return HCoercionTy + +resolveTyVarScopes :: M.Map HiePath (HieAST a) -> M.Map HiePath (HieAST a) +resolveTyVarScopes asts = M.map go asts + where + go ast = resolveTyVarScopeLocal ast asts + +resolveTyVarScopeLocal :: HieAST a -> M.Map HiePath (HieAST a) -> HieAST a +resolveTyVarScopeLocal ast asts = go ast + where + resolveNameScope dets = dets{identInfo = + S.map resolveScope (identInfo dets)} + resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBinding name asts] + ] + resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBindingInClass name sp asts] + ] + resolveScope scope = scope + go (Node info span children) = Node info' span $ map go children + where + info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info) + updateNodeInfo i = i { nodeIdentifiers = idents } + where + idents = M.map resolveNameScope $ nodeIdentifiers i + +getNameBinding :: Name -> M.Map HiePath (HieAST a) -> Maybe Span +getNameBinding n asts = do + (_,msp) <- getNameScopeAndBinding n asts + msp + +getNameScope :: Name -> M.Map HiePath (HieAST a) -> Maybe [Scope] +getNameScope n asts = do + (scopes,_) <- getNameScopeAndBinding n asts + return scopes + +getNameBindingInClass + :: Name + -> Span + -> M.Map HiePath (HieAST a) + -> Maybe Span +getNameBindingInClass n sp asts = do + ast <- M.lookup (HiePath (srcSpanFile sp)) asts + clsNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do + child <- flattenAst clsNode + dets <- maybeToList + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return (getFirst binding) + +getNameScopeAndBinding + :: Name + -> M.Map HiePath (HieAST a) + -> Maybe ([Scope], Maybe Span) +getNameScopeAndBinding n asts = case nameSrcSpan n of + RealSrcSpan sp _ -> do -- @Maybe + ast <- M.lookup (HiePath (srcSpanFile sp)) asts + defNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do -- @[] + node <- flattenAst defNode + dets <- maybeToList + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node + scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return $ Just (scopes, getFirst binding) + _ -> Nothing + +getScopeFromContext :: ContextInfo -> Maybe [Scope] +getScopeFromContext (ValBind _ sc _) = Just [sc] +getScopeFromContext (PatternBind a b _) = Just [a, b] +getScopeFromContext (ClassTyDecl _) = Just [ModuleScope] +getScopeFromContext (Decl _ _) = Just [ModuleScope] +getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs +getScopeFromContext (TyVarBind a _) = Just [a] +getScopeFromContext (EvidenceVarBind _ a _) = Just [a] +getScopeFromContext _ = Nothing + +getBindSiteFromContext :: ContextInfo -> Maybe Span +getBindSiteFromContext (ValBind _ _ sp) = sp +getBindSiteFromContext (PatternBind _ _ sp) = sp +getBindSiteFromContext _ = Nothing + +flattenAst :: HieAST a -> [HieAST a] +flattenAst n = + n : concatMap flattenAst (nodeChildren n) + +smallestContainingSatisfying + :: Span + -> (HieAST a -> Bool) + -> HieAST a + -> Maybe (HieAST a) +smallestContainingSatisfying sp cond node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . smallestContainingSatisfying sp cond) $ + nodeChildren node + , First $ if cond node then Just node else Nothing + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a) +selectLargestContainedBy sp node + | sp `containsSpan` nodeSpan node = Just node + | nodeSpan node `containsSpan` sp = + getFirst $ foldMap (First . selectLargestContainedBy sp) $ + nodeChildren node + | otherwise = Nothing + +selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a) +selectSmallestContaining sp node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node + , First (Just node) + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool +definedInAsts asts n = case nameSrcSpan n of + RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts + _ -> False + +getEvidenceBindDeps :: ContextInfo -> [Name] +getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) = + getEvBindDeps xs +getEvidenceBindDeps _ = [] + +isEvidenceBind :: ContextInfo -> Bool +isEvidenceBind EvidenceVarBind{} = True +isEvidenceBind _ = False + +isEvidenceContext :: ContextInfo -> Bool +isEvidenceContext EvidenceVarUse = True +isEvidenceContext EvidenceVarBind{} = True +isEvidenceContext _ = False + +isEvidenceUse :: ContextInfo -> Bool +isEvidenceUse EvidenceVarUse = True +isEvidenceUse _ = False + +isOccurrence :: ContextInfo -> Bool +isOccurrence Use = True +isOccurrence EvidenceVarUse = True +isOccurrence _ = False + +scopeContainsSpan :: Scope -> Span -> Bool +scopeContainsSpan NoScope _ = False +scopeContainsSpan ModuleScope _ = True +scopeContainsSpan (LocalScope a) b = a `containsSpan` b + +-- | One must contain the other. Leaf nodes cannot contain anything +combineAst :: HieAST Type -> HieAST Type -> HieAST Type +combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys) + | aSpn == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys) + | aSpn `containsSpan` bSpn = combineAst b a +combineAst a (Node xs span children) = Node xs span (insertAst a children) + +-- | Insert an AST in a sorted list of disjoint Asts +insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type] +insertAst x = mergeAsts [x] + +nodeInfo :: HieAST Type -> NodeInfo Type +nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo + +emptyNodeInfo :: NodeInfo a +emptyNodeInfo = NodeInfo S.empty [] M.empty + +sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a +sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo + +combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type +combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo + +-- | Merge two nodes together. +-- +-- Precondition and postcondition: elements in 'nodeType' are ordered. +combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type +(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) = + NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) + where + mergeSorted :: [Type] -> [Type] -> [Type] + mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of + LT -> a : mergeSorted as lb + EQ -> a : mergeSorted as bs + GT -> b : mergeSorted la bs + mergeSorted as [] = as + mergeSorted [] bs = bs + + +{- | Merge two sorted, disjoint lists of ASTs, combining when necessary. + +In the absence of position-altering pragmas (ex: @# line "file.hs" 3@), +different nodes in an AST tree should either have disjoint spans (in +which case you can say for sure which one comes first) or one span +should be completely contained in the other (in which case the contained +span corresponds to some child node). + +However, since Haskell does have position-altering pragmas it /is/ +possible for spans to be overlapping. Here is an example of a source file +in which @foozball@ and @quuuuuux@ have overlapping spans: + +@ +module Baz where + +# line 3 "Baz.hs" +foozball :: Int +foozball = 0 + +# line 3 "Baz.hs" +bar, quuuuuux :: Int +bar = 1 +quuuuuux = 2 +@ + +In these cases, we just do our best to produce sensible `HieAST`'s. The blame +should be laid at the feet of whoever wrote the line pragmas in the first place +(usually the C preprocessor...). +-} +mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type] +mergeAsts xs [] = xs +mergeAsts [] ys = ys +mergeAsts xs@(a:as) ys@(b:bs) + | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs + | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs) + | span_a `rightOf` span_b = b : mergeAsts xs bs + | span_a `leftOf` span_b = a : mergeAsts as ys + + -- These cases are to work around ASTs that are not fully disjoint + | span_a `startsRightOf` span_b = b : mergeAsts as ys + | otherwise = a : mergeAsts as ys + where + span_a = nodeSpan a + span_b = nodeSpan b + +rightOf :: Span -> Span -> Bool +rightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +leftOf :: Span -> Span -> Bool +leftOf s1 s2 + = (srcSpanEndLine s1, srcSpanEndCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +startsRightOf :: Span -> Span -> Bool +startsRightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanStartLine s2, srcSpanStartCol s2) + +-- | combines and sorts ASTs using a merge sort +mergeSortAsts :: [HieAST Type] -> [HieAST Type] +mergeSortAsts = go . map pure + where + go [] = [] + go [xs] = xs + go xss = go (mergePairs xss) + mergePairs [] = [] + mergePairs [xs] = [xs] + mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss + +simpleNodeInfo :: FastString -> FastString -> NodeInfo a +simpleNodeInfo cons typ = NodeInfo (S.singleton (NodeAnnotation cons typ)) [] M.empty + +locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a] +locOnly (RealSrcSpan span _) = do + org <- ask + let e = mkSourcedNodeInfo org $ emptyNodeInfo + pure [Node e span []] +locOnly _ = pure [] + +locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a] +locOnlyE (EpaSpan s) = locOnly s +locOnlyE _ = pure [] + +mkScope :: (HasLoc a) => a -> Scope +mkScope a = case getHasLoc a of + (RealSrcSpan sp _) -> LocalScope sp + _ -> NoScope + +combineScopes :: Scope -> Scope -> Scope +combineScopes ModuleScope _ = ModuleScope +combineScopes _ ModuleScope = ModuleScope +combineScopes NoScope x = x +combineScopes x NoScope = x +combineScopes (LocalScope a) (LocalScope b) = + mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing) + +mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a +mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni + +{-# INLINEABLE makeNodeA #-} +makeNodeA + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> EpAnn ann -- ^ return an empty list if this is unhelpful + -> ReaderT NodeOrigin m [HieAST b] +makeNodeA x spn = makeNode x (locA spn) + +{-# INLINEABLE makeNode #-} +makeNode + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> ReaderT NodeOrigin m [HieAST b] +makeNode x spn = do + org <- ask + pure $ case spn of + RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x + +{-# INLINEABLE makeTypeNodeA #-} +makeTypeNodeA + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpanAnnA -- ^ return an empty list if this is unhelpful + -> Type -- ^ type to associate with the node + -> ReaderT NodeOrigin m [HieAST Type] +makeTypeNodeA x spn etyp = makeTypeNode x (locA spn) etyp + +{-# INLINEABLE makeTypeNode #-} +makeTypeNode + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> Type -- ^ type to associate with the node + -> ReaderT NodeOrigin m [HieAST Type] +makeTypeNode x spn etyp = do + org <- ask + pure $ case spn of + RealSrcSpan span _ -> + [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x diff --git a/test/GHC/Iface/Ext/BinarySpec.hs b/test/GHC/Iface/Ext/BinarySpec.hs new file mode 100644 --- /dev/null +++ b/test/GHC/Iface/Ext/BinarySpec.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module GHC.Iface.Ext.BinarySpec (spec) where + +import Test.Hspec + +import Control.Concurrent (readMVar) +import Data.Maybe +import Data.String +import Data.Functor +import Data.Foldable +import Data.Map qualified as Map +import Data.ByteString.Char8 qualified as B + +import System.Process +import System.FilePath +import System.IO.Temp +import System.Environment.Blank (unsetEnv) + +import GHC.Unit.Types +import GHC.Types.SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Unit.Module.Env +import Language.Haskell.Syntax.Module.Name + +import GHC.Iface.Ext.Binary +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils () +import GHC.Iface.Ext.Debug () + +run :: CreateProcess -> IO () +run p = withCreateProcess p \ _ _ _ -> void . waitForProcess + +deriving instance Show unit => Show (GenModule unit) +deriving newtype instance IsString ModuleName +deriving newtype instance IsString UnitId + +instance IsString Unit where + fromString = RealUnit . Definite . fromString + +withHieFile :: String -> (FilePath -> IO b) -> IO b +withHieFile ghc action = do + withSystemTempDirectory "hspec" \ dir -> do + createHieFile ghc dir "Foo.hs" [ + "module Foo where" + , "foo :: Int" + , "foo = 23" + ] + action $ dir "Foo.hie" + +createHieFile :: FilePath -> FilePath -> FilePath -> [String] -> IO () +createHieFile ghc dir name contents = do + writeFile (dir name) $ unlines contents + unsetEnv "GHC_ENVIRONMENT" + run (proc ghc ["-v0", "-fwrite-ide-info", name]) { cwd = Just dir } + +supported :: [(String, Integer)] +supported = [ + ("9.8.4", 9084) + , ("9.10.1", 9101) + , ("9.10.2", 9102) + , ("9.12.1", 9121) + , ("9.12.2", 9122) + ] + +spec :: Spec +spec = do + describe "readHieFile" do + it "rejects HIE-files created with GHC 9.4.8" do + withHieFile "ghc-9.4.8" \ hieFile -> do + extractSourceFileName hieFile `shouldReturn` "Foo.hs" + let + message = + "Unsupported HIE version 9048 for file " + <> hieFile + <> ", supported versions: 9122, 9121, 9102, 9101, 9084, 9083, 9082, 9081" + expected = userError message + nameCache <- initNameCache 'r' mempty + readHieFile nameCache hieFile `shouldThrow` (== expected) + + for_ supported \ (ghcVersion, hieVersion) -> do + + let ghc = "ghc-" <> ghcVersion + + context ("with " <> ghc) do + + it "accepts HIE-files" do + withHieFile ghc \ hieFile -> do + extractSourceFileName hieFile `shouldReturn` "Foo.hs" + + nameCache <- initNameCache 'r' mempty + result <- readHieFile nameCache hieFile + + result.hie_file_result_version `shouldBe` hieVersion + result.hie_file_result_ghc_version `shouldBe` fromString ghcVersion + + let hie_file = result.hie_file_result + + hie_file.hie_hs_file `shouldBe` "Foo.hs" + hie_file.hie_module `shouldBe` Module "main" "Foo" + length hie_file.hie_types `shouldBe` 1 + Map.keys hie_file.hie_asts.getAsts `shouldBe` [HiePath "Foo.hs"] + length hie_file.hie_exports `shouldBe` 1 + hie_file.hie_hs_src `shouldBe` B.unlines [ + "module Foo where" + , "foo :: Int" + , "foo = 23" + ] + length hie_file.hie_entity_infos `shouldBe` if hieVersion < 9121 then 0 else 3 + + it "maintains precise locations in NameCache" do + withSystemTempDirectory "hspec" \ dir -> do + createHieFile ghc dir "Foo.hs" [ + "module Foo (foo) where" + , "" + , "" + , "foo :: Int" + , "foo = 23" + ] + createHieFile ghc dir "Bar.hs" [ + "module Bar where" + , "import qualified Foo" + , "bar :: Int" + , "bar = Foo.foo" + ] + createHieFile ghc dir "Foo.hs" [ + "module Foo (foo) where" + , "foo :: Int" + , "foo = 23" + ] + nameCache <- initNameCache 'r' mempty + _ <- readHieFile nameCache $ dir "Bar.hie" + _ <- readHieFile nameCache $ dir "Foo.hie" + + names <- moduleEnvElts <$> readMVar (nsNames nameCache) + + let + lookupFoo :: OccEnv Name -> Maybe Name + lookupFoo = flip lookupOccEnv $ mkOccName varName "foo" + + candidates :: [Name] + candidates = mapMaybe lookupFoo names + + expectedLocation :: SrcSpan + expectedLocation = mkSrcSpan (mkSrcLoc "Foo.hs" 3 1) (mkSrcLoc "Foo.hs" 3 4) + + map nameSrcSpan candidates `shouldBe` [expectedLocation] diff --git a/test/GHC/Iface/Ext/Upstream.hs b/test/GHC/Iface/Ext/Upstream.hs new file mode 100644 --- /dev/null +++ b/test/GHC/Iface/Ext/Upstream.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module GHC.Iface.Ext.Upstream (readHieFile) where + +import Prelude hiding (span) +import Data.Set qualified as Set +import Data.Map qualified as Map +import Data.Array.Base qualified as A + +import GHC.Types.Avail +import GHC.Types.Name.Cache +import "ghc" GHC.Iface.Ext.Types qualified as GHC +import "ghc" GHC.Iface.Ext.Binary qualified as GHC + +import GHC.Iface.Ext.Types + +deriving instance Eq AvailInfo +deriving instance Eq HieFile + +readHieFile :: FilePath -> NameCache -> IO HieFile +readHieFile hieFile nameCache = do + fromHieFile . GHC.hie_file_result <$> GHC.readHieFile nameCache hieFile + +fromHieFile :: GHC.HieFile -> HieFile +fromHieFile GHC.HieFile{..} = HieFile { + hie_hs_file +, hie_module +, hie_types = A.amap fromHieType hie_types +, hie_asts = fromHieASTs hie_asts +, hie_exports +, hie_hs_src +#if __GLASGOW_HASKELL__ >= 912 +, hie_entity_infos = Map.map (Set.map fromEntityInfo) hie_entity_infos +#else +, hie_entity_infos = mempty +#endif +} + +#if __GLASGOW_HASKELL__ >= 912 +fromEntityInfo :: GHC.EntityInfo -> EntityInfo +fromEntityInfo = \ case + GHC.EntityVariable -> EntityVariable + GHC.EntityFunction -> EntityFunction + GHC.EntityDataConstructor -> EntityDataConstructor + GHC.EntityTypeVariable -> EntityTypeVariable + GHC.EntityClassMethod -> EntityClassMethod + GHC.EntityPatternSynonym -> EntityPatternSynonym + GHC.EntityTypeConstructor -> EntityTypeConstructor + GHC.EntityTypeClass -> EntityTypeClass + GHC.EntityTypeSynonym -> EntityTypeSynonym + GHC.EntityTypeFamily -> EntityTypeFamily + GHC.EntityRecordField -> EntityRecordField +#endif + +fromHieType :: GHC.HieType a -> HieType a +fromHieType = \ case + GHC.HTyVarTy name -> HTyVarTy name + GHC.HAppTy a hieArgs -> HAppTy a (fromHieArgs hieArgs) + GHC.HTyConApp ifaceTyCon hieArgs -> HTyConApp ifaceTyCon (fromHieArgs hieArgs) + GHC.HForAllTy as a -> HForAllTy as a + GHC.HFunTy a b c -> HFunTy a b c + GHC.HQualTy a b -> HQualTy a b + GHC.HLitTy ifaceTyLit -> HLitTy ifaceTyLit + GHC.HCastTy a -> HCastTy a + GHC.HCoercionTy -> HCoercionTy + +fromHieArgs :: GHC.HieArgs a -> HieArgs a +fromHieArgs = \ case + GHC.HieArgs xs -> HieArgs xs + +fromHieASTs :: GHC.HieASTs a -> HieASTs a +fromHieASTs = \ case + GHC.HieASTs asts -> HieASTs $ Map.map fromHieAST asts + +fromHieAST :: GHC.HieAST a -> HieAST a +fromHieAST GHC.Node{..} = Node { + sourcedNodeInfo = fromSourcedNodeInfo sourcedNodeInfo +, nodeSpan +, nodeChildren = map fromHieAST nodeChildren +} + +fromSourcedNodeInfo :: GHC.SourcedNodeInfo a -> SourcedNodeInfo a +fromSourcedNodeInfo = + SourcedNodeInfo . Map.map fromNodeInfo . Map.mapKeys fromNodeOrigin . GHC.getSourcedNodeInfo + +fromNodeOrigin :: GHC.NodeOrigin -> NodeOrigin +fromNodeOrigin = \ case + GHC.SourceInfo -> SourceInfo + GHC.GeneratedInfo -> GeneratedInfo + +fromNodeInfo :: GHC.NodeInfo a -> NodeInfo a +fromNodeInfo GHC.NodeInfo{..} = NodeInfo { + nodeAnnotations = Set.map fromNodeAnnotation nodeAnnotations +, nodeType +, nodeIdentifiers = fromNodeIdentifiers nodeIdentifiers +} + +fromNodeAnnotation :: GHC.NodeAnnotation -> NodeAnnotation +fromNodeAnnotation GHC.NodeAnnotation{..} = NodeAnnotation{..} + +fromNodeIdentifiers :: GHC.NodeIdentifiers a -> NodeIdentifiers a +fromNodeIdentifiers = Map.map fromIdentifierDetails + +fromIdentifierDetails :: GHC.IdentifierDetails a -> IdentifierDetails a +fromIdentifierDetails GHC.IdentifierDetails{..} = IdentifierDetails { + identType +, identInfo = Set.map fromContextInfo identInfo +} + +fromBindType :: GHC.BindType -> BindType +fromBindType = \ case + GHC.RegularBind -> RegularBind + GHC.InstanceBind -> InstanceBind + +fromDeclType :: GHC.DeclType -> DeclType +fromDeclType = \ case + GHC.FamDec -> FamDec + GHC.SynDec -> SynDec + GHC.DataDec -> DataDec + GHC.InstDec -> InstDec + GHC.PatSynDec -> PatSynDec + GHC.ClassDec -> ClassDec + GHC.ConDec -> ConDec + +fromTyVarScope :: GHC.TyVarScope -> TyVarScope +fromTyVarScope = \case + GHC.ResolvedScopes scopes -> ResolvedScopes $ map fromScope scopes + GHC.UnresolvedScope a b -> UnresolvedScope a b + +fromRecFieldContext :: GHC.RecFieldContext -> RecFieldContext +fromRecFieldContext = \ case + GHC.RecFieldDecl -> RecFieldDecl + GHC.RecFieldAssign -> RecFieldAssign + GHC.RecFieldMatch -> RecFieldMatch + GHC.RecFieldOcc -> RecFieldOcc + +fromContextInfo :: GHC.ContextInfo -> ContextInfo +fromContextInfo = \ case + GHC.Use -> Use + GHC.MatchBind -> MatchBind + GHC.IEThing iEType -> IEThing (fromIEType iEType) + GHC.TyDecl -> TyDecl + GHC.ValBind bindType scope span -> ValBind (fromBindType bindType) (fromScope scope) span + GHC.PatternBind scopeA scopeB span -> PatternBind (fromScope scopeA) (fromScope scopeB) span + GHC.ClassTyDecl span -> ClassTyDecl span + GHC.Decl declType span -> Decl (fromDeclType declType) span + GHC.TyVarBind scope tyVarScope -> TyVarBind (fromScope scope) (fromTyVarScope tyVarScope) + GHC.RecField recFieldContext span -> RecField (fromRecFieldContext recFieldContext) span + GHC.EvidenceVarBind evVarSource scope span -> EvidenceVarBind (fromEvVarSource evVarSource) (fromScope scope) span + GHC.EvidenceVarUse -> EvidenceVarUse + +fromIEType :: GHC.IEType -> IEType +fromIEType = \ case + GHC.Import -> Import + GHC.ImportAs -> ImportAs + GHC.ImportHiding -> ImportHiding + GHC.Export -> Export + +fromScope :: GHC.Scope -> Scope +fromScope = \ case + GHC.NoScope -> NoScope + GHC.LocalScope span -> LocalScope span + GHC.ModuleScope -> ModuleScope + +fromEvVarSource :: GHC.EvVarSource -> EvVarSource +fromEvVarSource = \ case + GHC.EvPatternBind -> EvPatternBind + GHC.EvSigBind -> EvSigBind + GHC.EvWrapperBind -> EvWrapperBind + GHC.EvImplicitBind -> EvImplicitBind + GHC.EvInstBind { isSuperInst, cls } -> EvInstBind { isSuperInst, cls } + GHC.EvLetBind evBindDeps -> EvLetBind (fromEvBindDeps evBindDeps) + +fromEvBindDeps :: GHC.EvBindDeps -> EvBindDeps +fromEvBindDeps = \ case + GHC.EvBindDeps xs -> EvBindDeps xs diff --git a/test/SmokeSpec.hs b/test/SmokeSpec.hs new file mode 100644 --- /dev/null +++ b/test/SmokeSpec.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +module SmokeSpec (spec) where + +import Test.Hspec +import Test.QuickCheck + +import Foreign (Ptr, peek) +import Data.Word +import Data.Foldable +import Control.Exception (bracket_) +import System.Environment (lookupEnv) +import System.Process + +import GHC.Types.Name.Cache +import GHC.Settings.Config (cProjectUnitId) +import GHC.Types.Unique.Supply (initUniqSupply) + +import GHC.Iface.Ext.Binary +import GHC.Iface.Ext.BinarySpec () +import qualified GHC.Iface.Ext.Upstream as Upstream + +foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64 +foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int + +withDeterministicUniqueSupply :: IO a -> IO a +withDeterministicUniqueSupply action = do + counter <- peek ghc_unique_counter64 + increment <- peek ghc_unique_inc + bracket_ (initUniqSupply 0 1) (initUniqSupply counter increment) action + +findHieFiles :: IO [FilePath] +findHieFiles = lookupEnv "CI" >>= \ case + Nothing -> return []; Just + _ -> lines <$> readCreateProcess (shell $ "find " <> store <> " -name '*.hie'") "" + where + store = "~/.local/state/cabal/store/" <> cProjectUnitId + +spec :: Spec +spec = do + describe "withDeterministicUniqueSupply" do + it "runs an action with a deterministic unique supply" do + withDeterministicUniqueSupply do + peek ghc_unique_counter64 `shouldReturn` 0 + peek ghc_unique_inc `shouldReturn` 1 + + it "restores the original unique supply when done" do + counter <- peek ghc_unique_counter64 + increment <- peek ghc_unique_inc + withDeterministicUniqueSupply do + initUniqSupply 23 42 + peek ghc_unique_counter64 `shouldReturn` 23 + peek ghc_unique_inc `shouldReturn` 42 + peek ghc_unique_counter64 `shouldReturn` counter + peek ghc_unique_inc `shouldReturn` increment + + describe "smoke tests" do + runIO findHieFiles >>= traverse_ \ hieFile -> do + it hieFile do + theirs <- withDeterministicUniqueSupply do + nameCache <- initNameCache 'r' mempty + Upstream.readHieFile hieFile nameCache + mine <- withDeterministicUniqueSupply do + nameCache <- initNameCache 'r' mempty + hie_file_result <$> readHieFile nameCache hieFile + Blind mine `shouldBe` Blind theirs diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}