hi-file-parser 0.1.6.0 → 0.1.7.0
raw patch · 20 files changed
+816/−789 lines, 20 filesbinary-addedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +5/−0
- hi-file-parser.cabal +12/−8
- src/HiFileParser.hs +794/−778
- test-files/iface/x64/ghc9027/Main.hi binary
- test-files/iface/x64/ghc9027/X.hi binary
- test-files/iface/x64/ghc9028/Main.hi binary
- test-files/iface/x64/ghc9028/X.hi binary
- test-files/iface/x64/ghc9063/Main.hi binary
- test-files/iface/x64/ghc9063/X.hi binary
- test-files/iface/x64/ghc9066/Main.hi binary
- test-files/iface/x64/ghc9066/X.hi binary
- test-files/iface/x64/ghc9081/Main.hi binary
- test-files/iface/x64/ghc9081/X.hi binary
- test-files/iface/x64/ghc9083/Main.hi binary
- test-files/iface/x64/ghc9083/X.hi binary
- test-files/iface/x64/ghc9101/Main.hi binary
- test-files/iface/x64/ghc9101/X.hi binary
- test-files/iface/x64/ghc9120/Main.hi binary
- test-files/iface/x64/ghc9120/X.hi binary
- test/HiFileParserSpec.hs +5/−3
ChangeLog.md view
@@ -6,6 +6,11 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.1.7.0 - 2024-10-22 + +* Add support for GHC 9.12 (GHC 9.12.1 onward). See + [#23](https://github.com/commercialhaskell/hi-file-parser/pull/23) + ## 0.1.6.0 - 2023-11-04 * Add further support for GHC 9.8 (GHC 9.8.1 onward). See
hi-file-parser.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: hi-file-parser -version: 0.1.6.0 +version: 0.1.7.0 synopsis: Parser for GHC's hi files description: Please see the README on Github at <https://github.com/commercialhaskell/hi-file-parser/blob/master/README.md> category: Development @@ -35,16 +35,20 @@ test-files/iface/x64/ghc8107/X.hi test-files/iface/x64/ghc9002/Main.hi test-files/iface/x64/ghc9002/X.hi - test-files/iface/x64/ghc9027/Main.hi - test-files/iface/x64/ghc9027/X.hi + test-files/iface/x64/ghc9028/Main.hi + test-files/iface/x64/ghc9028/X.hi test-files/iface/x64/ghc9044/Main.hi test-files/iface/x64/ghc9044/X.hi test-files/iface/x64/ghc9047/Main.hi test-files/iface/x64/ghc9047/X.hi - test-files/iface/x64/ghc9063/Main.hi - test-files/iface/x64/ghc9063/X.hi - test-files/iface/x64/ghc9081/Main.hi - test-files/iface/x64/ghc9081/X.hi + test-files/iface/x64/ghc9066/Main.hi + test-files/iface/x64/ghc9066/X.hi + test-files/iface/x64/ghc9083/Main.hi + test-files/iface/x64/ghc9083/X.hi + test-files/iface/x64/ghc9101/Main.hi + test-files/iface/x64/ghc9101/X.hi + test-files/iface/x64/ghc9120/Main.hi + test-files/iface/x64/ghc9120/X.hi source-repository head type: git
src/HiFileParser.hs view
@@ -1,778 +1,794 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} - -module HiFileParser - ( Interface(..) - , List(..) - , Dictionary(..) - , Module(..) - , Usage(..) - , Dependencies(..) - , getInterface - , fromFile - ) where - -{- HLINT ignore "Reduce duplication" -} - -import Control.Monad (replicateM, replicateM_, when) -import Data.Binary (Word64,Word32,Word8) -import qualified Data.Binary.Get as G (Get, Decoder (..), bytesRead, - getByteString, getInt64be, - getWord32be, getWord64be, - getWord8, lookAhead, - runGetIncremental, skip) -import Data.Bool (bool) -import Data.ByteString.Lazy.Internal (defaultChunkSize) -import Data.Char (chr) -import Data.Functor (void, ($>)) -import Data.Maybe (catMaybes) -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup ((<>)) -#endif -import qualified Data.Vector as V -import qualified Data.Text.Encoding as Text -import qualified Data.Text as Text -import GHC.IO.IOMode (IOMode (..)) -import Numeric (showHex) -import RIO.ByteString as B (ByteString, hGetSome, null) -import RIO (Int64,Generic, NFData) -import System.IO (withBinaryFile) -import Data.Bits (FiniteBits(..),testBit, - unsafeShiftL,(.|.),clearBit, - complement) -import Control.Monad.State (StateT, evalStateT, get, gets, - lift, modify) -import qualified Debug.Trace - -newtype IfaceGetState = IfaceGetState - { useLEB128 :: Bool -- ^ Use LEB128 encoding for numbers - } - -data IfaceVersion - = V7021 - | V7041 - | V7061 - | V7081 - | V8001 - | V8021 - | V8041 - | V8061 - | V8101 - | V9001 - | V9041 - | V9045 - | V9081 - deriving (Show,Eq,Ord,Enum) - -- careful, the Ord matters! - - -type Get a = StateT IfaceGetState G.Get a - -enableDebug :: Bool -enableDebug = False - -traceGet :: String -> Get () -traceGet s - | enableDebug = Debug.Trace.trace s (return ()) - | otherwise = return () - -traceShow :: Show a => String -> Get a -> Get a -traceShow s g - | not enableDebug = g - | otherwise = do - a <- g - traceGet (s ++ " " ++ show a) - return a - -runGetIncremental :: Get a -> G.Decoder a -runGetIncremental g = G.runGetIncremental (evalStateT g emptyState) - where - emptyState = IfaceGetState False - -getByteString :: Int -> Get ByteString -getByteString i = lift (G.getByteString i) - -getWord8 :: Get Word8 -getWord8 = lift G.getWord8 - -bytesRead :: Get Int64 -bytesRead = lift G.bytesRead - -skip :: Int -> Get () -skip = lift . G.skip - -uleb :: Get a -> Get a -> Get a -uleb f g = do - c <- gets useLEB128 - if c then f else g - -getWord32be :: Get Word32 -getWord32be = uleb getULEB128 (lift G.getWord32be) - -getWord64be :: Get Word64 -getWord64be = uleb getULEB128 (lift G.getWord64be) - -getInt64be :: Get Int64 -getInt64be = uleb getSLEB128 (lift G.getInt64be) - -lookAhead :: Get b -> Get b -lookAhead g = do - s <- get - lift $ G.lookAhead (evalStateT g s) - -getPtr :: Get Word32 -getPtr = lift G.getWord32be - -type IsBoot = Bool - -type ModuleName = ByteString - -newtype List a = List - { unList :: [a] - } deriving newtype (Show, NFData) - -newtype Dictionary = Dictionary - { unDictionary :: V.Vector ByteString - } deriving newtype (Show, NFData) - -newtype Module = Module - { unModule :: ModuleName - } deriving newtype (Show, NFData) - -newtype Usage = Usage - { unUsage :: FilePath - } deriving newtype (Show, NFData) - -data Dependencies = Dependencies - { dmods :: List (ModuleName, IsBoot) - , dpkgs :: List (ModuleName, Bool) - , dorphs :: List Module - , dfinsts :: List Module - , dplugins :: List ModuleName - } deriving (Show, Generic) -instance NFData Dependencies - -data Interface = Interface - { deps :: Dependencies - , usage :: List Usage - } deriving (Show, Generic) -instance NFData Interface - --- | Read a block prefixed with its length -withBlockPrefix :: Get a -> Get a -withBlockPrefix f = getPtr *> f - -getBool :: Get Bool -getBool = toEnum . fromIntegral <$> getWord8 - -getString :: Get String -getString = fmap (chr . fromIntegral) . unList <$> getList getWord32be - -getMaybe :: Get a -> Get (Maybe a) -getMaybe f = bool (pure Nothing) (Just <$> f) =<< getBool - -getList :: Get a -> Get (List a) -getList f = do - use_uleb <- gets useLEB128 - if use_uleb - then do - l <- (getSLEB128 :: Get Int64) - List <$> replicateM (fromIntegral l) f - else do - i <- getWord8 - l <- - if i == 0xff - then getWord32be - else pure (fromIntegral i :: Word32) - List <$> replicateM (fromIntegral l) f - -getTuple :: Get a -> Get b -> Get (a, b) -getTuple f g = (,) <$> f <*> g - -getByteStringSized :: Get ByteString -getByteStringSized = do - size <- getInt64be - getByteString (fromIntegral size) - -getDictionary :: Int -> Get Dictionary -getDictionary ptr = do - offset <- bytesRead - skip $ ptr - fromIntegral offset - size <- fromIntegral <$> getInt64be - traceGet ("Dictionary size: " ++ show size) - dict <- Dictionary <$> V.replicateM size getByteStringSized - traceGet ("Dictionary: " ++ show dict) - return dict - --- | Get a FastString --- --- FastStrings are stored in a global FastString table and only the index (a --- Word32be) is stored at the expected position. -getCachedBS :: Dictionary -> Get ByteString -getCachedBS d = go =<< traceShow "Dict index:" getWord32be - where - go i = - case unDictionary d V.!? fromIntegral i of - Just bs -> pure bs - Nothing -> fail $ "Invalid dictionary index: " <> show i - --- | Get Fingerprint -getFP' :: Get String -getFP' = do - x <- getWord64be - y <- getWord64be - return (showHex x (showHex y "")) - -getFP :: Get () -getFP = void getFP' - -getInterface721 :: Dictionary -> Get Interface -getInterface721 d = do - void getModule - void getBool - replicateM_ 2 getFP - void getBool - void getBool - Interface <$> getDependencies <*> getUsage - where - getModule = getCachedBS d *> (Module <$> getCachedBS d) - getDependencies = - withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> - getList (getTuple (getCachedBS d) getBool) <*> - getList getModule <*> - getList getModule <*> - pure (List []) - getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go - where - go :: Get (Maybe Usage) - go = do - usageType <- getWord8 - case usageType of - 0 -> getModule *> getFP *> getBool $> Nothing - 1 -> - getCachedBS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedBS d) getFP) *> - getBool $> Nothing - _ -> fail $ "Invalid usageType: " <> show usageType - -getInterface741 :: Dictionary -> Get Interface -getInterface741 d = do - void getModule - void getBool - replicateM_ 3 getFP - void getBool - void getBool - Interface <$> getDependencies <*> getUsage - where - getModule = getCachedBS d *> (Module <$> getCachedBS d) - getDependencies = - withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> - getList (getTuple (getCachedBS d) getBool) <*> - getList getModule <*> - getList getModule <*> - pure (List []) - getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go - where - go :: Get (Maybe Usage) - go = do - usageType <- getWord8 - case usageType of - 0 -> getModule *> getFP *> getBool $> Nothing - 1 -> - getCachedBS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedBS d) getFP) *> - getBool $> Nothing - 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be - _ -> fail $ "Invalid usageType: " <> show usageType - -getInterface761 :: Dictionary -> Get Interface -getInterface761 d = do - void getModule - void getBool - replicateM_ 3 getFP - void getBool - void getBool - Interface <$> getDependencies <*> getUsage - where - getModule = getCachedBS d *> (Module <$> getCachedBS d) - getDependencies = - withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> - getList (getTuple (getCachedBS d) getBool) <*> - getList getModule <*> - getList getModule <*> - pure (List []) - getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go - where - go :: Get (Maybe Usage) - go = do - usageType <- getWord8 - case usageType of - 0 -> getModule *> getFP *> getBool $> Nothing - 1 -> - getCachedBS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedBS d) getFP) *> - getBool $> Nothing - 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be - _ -> fail $ "Invalid usageType: " <> show usageType - -getInterface781 :: Dictionary -> Get Interface -getInterface781 d = do - void getModule - void getBool - replicateM_ 3 getFP - void getBool - void getBool - Interface <$> getDependencies <*> getUsage - where - getModule = getCachedBS d *> (Module <$> getCachedBS d) - getDependencies = - withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> - getList (getTuple (getCachedBS d) getBool) <*> - getList getModule <*> - getList getModule <*> - pure (List []) - getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go - where - go :: Get (Maybe Usage) - go = do - usageType <- getWord8 - case usageType of - 0 -> getModule *> getFP *> getBool $> Nothing - 1 -> - getCachedBS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedBS d) getFP) *> - getBool $> Nothing - 2 -> Just . Usage <$> getString <* getFP - _ -> fail $ "Invalid usageType: " <> show usageType - -getInterface801 :: Dictionary -> Get Interface -getInterface801 d = do - void getModule - void getWord8 - replicateM_ 3 getFP - void getBool - void getBool - Interface <$> getDependencies <*> getUsage - where - getModule = getCachedBS d *> (Module <$> getCachedBS d) - getDependencies = - withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> - getList (getTuple (getCachedBS d) getBool) <*> - getList getModule <*> - getList getModule <*> - pure (List []) - getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go - where - go :: Get (Maybe Usage) - go = do - usageType <- getWord8 - case usageType of - 0 -> getModule *> getFP *> getBool $> Nothing - 1 -> - getCachedBS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedBS d) getFP) *> - getBool $> Nothing - 2 -> Just . Usage <$> getString <* getFP - 3 -> getModule *> getFP $> Nothing - _ -> fail $ "Invalid usageType: " <> show usageType - -getInterface821 :: Dictionary -> Get Interface -getInterface821 d = do - void getModule - void $ getMaybe getModule - void getWord8 - replicateM_ 3 getFP - void getBool - void getBool - Interface <$> getDependencies <*> getUsage - where - getModule = do - idType <- getWord8 - case idType of - 0 -> void $ getCachedBS d - _ -> - void $ - getCachedBS d *> getList (getTuple (getCachedBS d) getModule) - Module <$> getCachedBS d - getDependencies = - withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> - getList (getTuple (getCachedBS d) getBool) <*> - getList getModule <*> - getList getModule <*> - pure (List []) - getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go - where - go :: Get (Maybe Usage) - go = do - usageType <- getWord8 - case usageType of - 0 -> getModule *> getFP *> getBool $> Nothing - 1 -> - getCachedBS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedBS d) getFP) *> - getBool $> Nothing - 2 -> Just . Usage <$> getString <* getFP - 3 -> getModule *> getFP $> Nothing - _ -> fail $ "Invalid usageType: " <> show usageType - -getInterface841 :: Dictionary -> Get Interface -getInterface841 d = do - void getModule - void $ getMaybe getModule - void getWord8 - replicateM_ 5 getFP - void getBool - void getBool - Interface <$> getDependencies <*> getUsage - where - getModule = do - idType <- getWord8 - case idType of - 0 -> void $ getCachedBS d - _ -> - void $ - getCachedBS d *> getList (getTuple (getCachedBS d) getModule) - Module <$> getCachedBS d - getDependencies = - withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> - getList (getTuple (getCachedBS d) getBool) <*> - getList getModule <*> - getList getModule <*> - pure (List []) - getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go - where - go :: Get (Maybe Usage) - go = do - usageType <- getWord8 - case usageType of - 0 -> getModule *> getFP *> getBool $> Nothing - 1 -> - getCachedBS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedBS d) getFP) *> - getBool $> Nothing - 2 -> Just . Usage <$> getString <* getFP - 3 -> getModule *> getFP $> Nothing - _ -> fail $ "Invalid usageType: " <> show usageType - -getInterface861 :: Dictionary -> Get Interface -getInterface861 d = do - void getModule - void $ getMaybe getModule - void getWord8 - replicateM_ 6 getFP - void getBool - void getBool - Interface <$> getDependencies <*> getUsage - where - getModule = do - idType <- getWord8 - case idType of - 0 -> void $ getCachedBS d - _ -> - void $ - getCachedBS d *> getList (getTuple (getCachedBS d) getModule) - Module <$> getCachedBS d - getDependencies = - withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> - getList (getTuple (getCachedBS d) getBool) <*> - getList getModule <*> - getList getModule <*> - getList (getCachedBS d) - getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go - where - go :: Get (Maybe Usage) - go = do - usageType <- getWord8 - case usageType of - 0 -> getModule *> getFP *> getBool $> Nothing - 1 -> - getCachedBS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedBS d) getFP) *> - getBool $> Nothing - 2 -> Just . Usage <$> getString <* getFP - 3 -> getModule *> getFP $> Nothing - _ -> fail $ "Invalid usageType: " <> show usageType - -getInterfaceRecent :: IfaceVersion -> Dictionary -> Get Interface -getInterfaceRecent version d = do - void $ traceShow "Module:" getModule - void $ traceShow "Sig:" $ getMaybe getModule - void getWord8 -- hsc_src - getFP -- iface_hash - getFP -- mod_hash - getFP -- flag_hash - getFP -- opt_hash - getFP -- hpc_hash - getFP -- plugin_hash - void getBool -- orphan - void getBool -- hasFamInsts - ddeps <- traceShow "Dependencies:" getDependencies - dusage <- traceShow "Usage:" getUsage - pure (Interface ddeps dusage) - where - since v = when (version >= v) - - getFastString = getCachedBS d - - getModule = do - idType <- traceShow "Unit type:" getWord8 - case idType of - 0 -> void getFastString - 1 -> - void $ - getFastString *> getList (getTuple getFastString getModule) - _ -> fail $ "Invalid unit type: " <> show idType - Module <$> getFastString - getDependencies = - withBlockPrefix $ do - if version >= V9041 - then do - -- warning: transitive dependencies are no longer stored, - -- only direct imports! - -- Modules are now prefixed with their UnitId (should have been - -- ModuleWithIsBoot...) - direct_mods <- traceShow "direct_mods:" $ getList (getFastString *> getTuple getFastString getBool) - direct_pkgs <- getList getFastString - - -- plugin packages are now stored separately - plugin_pkgs <- getList getFastString - let all_pkgs = unList plugin_pkgs ++ unList direct_pkgs - - -- instead of a trust bool for each unit, we have an additional - -- list of trusted units (transitive) - trusted_pkgs <- getList getFastString - let trusted u = u `elem` unList trusted_pkgs - let all_pkgs_trust = List (zip all_pkgs (map trusted all_pkgs)) - - -- these are new - _sig_mods <- getList getModule - _boot_mods <- getList (getFastString *> getTuple getFastString getBool) - - dep_orphs <- getList getModule - dep_finsts <- getList getModule - - -- plugin names are no longer stored here - let dep_plgins = List [] - - pure (Dependencies direct_mods all_pkgs_trust dep_orphs dep_finsts dep_plgins) - else do - dep_mods <- getList (getTuple getFastString getBool) - dep_pkgs <- getList (getTuple getFastString getBool) - dep_orphs <- getList getModule - dep_finsts <- getList getModule - dep_plgins <- getList getFastString - pure (Dependencies dep_mods dep_pkgs dep_orphs dep_finsts dep_plgins) - - getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go - where - -- this must follow the `Binary Usage` instance in GHC - -- (in GHC.Unit.Module.Deps, at least in GHC 9.4.5) - go :: Get (Maybe Usage) - go = do - usageType <- traceShow "Usage type:" getWord8 - case usageType of - 0 -> do - void (traceShow "Module:" getModule) -- usg_mod - void getFP -- usg_mod_hash - void getBool -- usg_safe - pure Nothing - - 1 -> do - void (traceShow "Home module:" getFastString) -- usg_mod_name - since V9045 $ void getFastString -- usg_unit_id - void getFP -- usg_mod_hash - void (getMaybe getFP) -- usg_exports - void getEntitiesList -- usg_entities - void getBool -- usg_safe - pure Nothing - - 2 -> do - -- usg_file_path - file_path <- traceShow "File:" $ if version >= V9081 - then Text.unpack . Text.decodeUtf8 <$> getFastString - else getString - void $ traceShow "FP:" getFP' -- usg_file_hash - since V9041 $ void $ traceShow "File label:" (getMaybe getString)-- usg_file_label - pure (Just (Usage file_path)) - - 3 -> do - void getModule -- usg_mod - void getFP -- usg_mod_hash - pure Nothing - - 4 | version >= V9041 -> do -- UsageHomeModuleInterface - void getFastString -- usg_mod_name - since V9045 $ void getFastString -- usg_unit_id - void getFP -- usg_iface_hash - pure Nothing - - _ -> fail $ "Invalid usageType: " <> show usageType - - getEntitiesList :: Get (List (ByteString, ())) - getEntitiesList = getList (getTuple (getNameSpace *> getFastString) getFP) - - -- See `instance Binary NameSpace` in module GHC.Types.Name.Occurrence. We - -- discard the information. - getNameSpace :: Get () - getNameSpace = if version >= V9081 - then do - nameSpaceType <- getWord8 - case nameSpaceType of - 0 -> pure () - 1 -> pure () - 2 -> pure () - 3 -> pure () - -- Unlike the original, we test that the byte we have obtained is - -- valid. - 4 -> do - void getFastString - _ -> fail $ "Invalid NameSpace type: " <> show nameSpaceType - else void getWord8 - -getInterface :: Get Interface -getInterface = do - let enableLEB128 = modify (\c -> c { useLEB128 = True}) - - magic <- lookAhead getWord32be >>= \case - -- normal magic - 0x1face -> getWord32be - 0x1face64 -> getWord32be - m -> do - -- GHC 8.10 mistakenly encoded header fields with LEB128 - -- so it gets special treatment - lookAhead (enableLEB128 >> getWord32be) >>= \case - 0x1face -> enableLEB128 >> getWord32be - 0x1face64 -> enableLEB128 >> getWord32be - _ -> fail $ "Invalid magic: " <> showHex m "" - - traceGet ("Magic: " ++ showHex magic "") - - -- empty field (removed in 9.0...) - case magic of - 0x1face -> do - e <- lookAhead getWord32be - if e == 0 - then void getWord32be - else enableLEB128 -- > 9.0 - 0x1face64 -> do - e <- lookAhead getWord64be - if e == 0 - then void getWord64be - else enableLEB128 -- > 9.0 - _ -> return () - - -- ghc version - version <- getString - traceGet ("Version: " ++ version) - - let !ifaceVersion - | version >= "9081" = V9081 - | version >= "9045" = V9045 - | version >= "9041" = V9041 - | version >= "9001" = V9001 - | version >= "8101" = V8101 - | version >= "8061" = V8061 - | version >= "8041" = V8041 - | version >= "8021" = V8021 - | version >= "8001" = V8001 - | version >= "7081" = V7081 - | version >= "7061" = V7061 - | version >= "7041" = V7041 - | version >= "7021" = V7021 - | otherwise = error $ "Unsupported version: " <> version - - -- way - way <- getString - traceGet ("Ways: " ++ show way) - - -- source hash (GHC >= 9.4) - when (ifaceVersion >= V9041) $ void getFP - - -- extensible fields (GHC >= 9.0) - when (ifaceVersion >= V9001) $ void getPtr - - -- dict_ptr - dictPtr <- getPtr - traceGet ("Dict ptr: " ++ show dictPtr) - - -- dict - dict <- lookAhead $ getDictionary $ fromIntegral dictPtr - - -- symtable_ptr - void getPtr - - case ifaceVersion of - V9081 -> getInterfaceRecent ifaceVersion dict - V9045 -> getInterfaceRecent ifaceVersion dict - V9041 -> getInterfaceRecent ifaceVersion dict - V9001 -> getInterfaceRecent ifaceVersion dict - V8101 -> getInterfaceRecent ifaceVersion dict - V8061 -> getInterface861 dict - V8041 -> getInterface841 dict - V8021 -> getInterface821 dict - V8001 -> getInterface801 dict - V7081 -> getInterface781 dict - V7061 -> getInterface761 dict - V7041 -> getInterface741 dict - V7021 -> getInterface721 dict - - -fromFile :: FilePath -> IO (Either String Interface) -fromFile fp = withBinaryFile fp ReadMode go - where - go h = - let feed (G.Done _ _ iface) = pure $ Right iface - feed (G.Fail _ _ msg) = pure $ Left msg - feed (G.Partial k) = do - chunk <- hGetSome h defaultChunkSize - feed $ k $ if B.null chunk then Nothing else Just chunk - in feed $ runGetIncremental getInterface - - -getULEB128 :: forall a. (Integral a, FiniteBits a) => Get a -getULEB128 = - go 0 0 - where - go :: Int -> a -> Get a - go shift w = do - b <- getWord8 - 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 - -getSLEB128 :: forall a. (Integral a, FiniteBits a) => Get a -getSLEB128 = 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 -> Get (a,Int,Bool) - go shift val = do - byte <- getWord8 - 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) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HiFileParser + ( Interface (..) + , List (..) + , Dictionary (..) + , Module (..) + , Usage (..) + , Dependencies (..) + , getInterface + , fromFile + ) where + +{- HLINT ignore "Reduce duplication" -} + +import Control.Monad ( replicateM, replicateM_, when ) +import Data.Binary ( Word32, Word64, Word8) +import qualified Data.Binary.Get as G + ( Decoder (..), Get, bytesRead, getByteString, getInt64be + , getWord32be, getWord64be, getWord8, lookAhead + , runGetIncremental, skip + ) +import Data.Bool ( bool ) +import Data.ByteString.Lazy.Internal ( defaultChunkSize ) +import Data.Char ( chr ) +import Data.Functor ( ($>), void ) +import Data.Maybe ( catMaybes ) +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ( (<>) ) +#endif +import qualified Data.Vector as V +import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text +import GHC.IO.IOMode ( IOMode (..) ) +import Numeric ( showHex ) +import RIO.ByteString as B ( ByteString, hGetSome, null ) +import RIO ( Generic, Int64, NFData ) +import System.IO ( withBinaryFile ) +import Data.Bits + ( FiniteBits (..), (.|.), clearBit, complement, testBit + , unsafeShiftL + ) +import Control.Monad.State + ( StateT, evalStateT, get, gets, lift, modify ) +import qualified Debug.Trace + +newtype IfaceGetState = IfaceGetState + { useLEB128 :: Bool -- ^ Use LEB128 encoding for numbers + } + +data IfaceVersion + = V7021 + | V7041 + | V7061 + | V7081 + | V8001 + | V8021 + | V8041 + | V8061 + | V8101 + | V9001 + | V9041 + | V9045 + | V9081 + | V9120 + deriving (Eq, Enum, Ord, Show) + -- careful, the Ord matters! + + +type Get a = StateT IfaceGetState G.Get a + +enableDebug :: Bool +enableDebug = False + +traceGet :: String -> Get () +traceGet s + | enableDebug = Debug.Trace.trace s (return ()) + | otherwise = return () + +traceShow :: Show a => String -> Get a -> Get a +traceShow s g + | not enableDebug = g + | otherwise = do + a <- g + traceGet (s ++ " " ++ show a) + return a + +runGetIncremental :: Get a -> G.Decoder a +runGetIncremental g = G.runGetIncremental (evalStateT g emptyState) + where + emptyState = IfaceGetState False + +getByteString :: Int -> Get ByteString +getByteString i = lift (G.getByteString i) + +getWord8 :: Get Word8 +getWord8 = lift G.getWord8 + +bytesRead :: Get Int64 +bytesRead = lift G.bytesRead + +skip :: Int -> Get () +skip = lift . G.skip + +uleb :: Get a -> Get a -> Get a +uleb f g = do + c <- gets useLEB128 + if c then f else g + +getWord32be :: Get Word32 +getWord32be = uleb getULEB128 (lift G.getWord32be) + +getWord64be :: Get Word64 +getWord64be = uleb getULEB128 (lift G.getWord64be) + +getInt64be :: Get Int64 +getInt64be = uleb getSLEB128 (lift G.getInt64be) + +lookAhead :: Get b -> Get b +lookAhead g = do + s <- get + lift $ G.lookAhead (evalStateT g s) + +getPtr :: Get Word32 +getPtr = lift G.getWord32be + +type IsBoot = Bool + +type ModuleName = ByteString + +newtype List a = List + { unList :: [a] + } deriving newtype (NFData, Show) + +newtype Dictionary = Dictionary + { unDictionary :: V.Vector ByteString + } deriving newtype (NFData, Show) + +newtype Module = Module + { unModule :: ModuleName + } deriving newtype (NFData, Show) + +newtype Usage = Usage + { unUsage :: FilePath + } deriving newtype (NFData, Show) + +data Dependencies = Dependencies + { dmods :: List (ModuleName, IsBoot) + , dpkgs :: List (ModuleName, Bool) + , dorphs :: List Module + , dfinsts :: List Module + , dplugins :: List ModuleName + } deriving (Generic, Show) + +instance NFData Dependencies + +data Interface = Interface + { deps :: Dependencies + , usage :: List Usage + } deriving (Generic, Show) + +instance NFData Interface + +-- | Read a block prefixed with its length +withBlockPrefix :: Get a -> Get a +withBlockPrefix f = getPtr *> f + +getBool :: Get Bool +getBool = toEnum . fromIntegral <$> getWord8 + +getString :: Get String +getString = fmap (chr . fromIntegral) . unList <$> getList getWord32be + +getMaybe :: Get a -> Get (Maybe a) +getMaybe f = bool (pure Nothing) (Just <$> f) =<< getBool + +getList :: Get a -> Get (List a) +getList f = do + use_uleb <- gets useLEB128 + if use_uleb + then do + l <- (getSLEB128 :: Get Int64) + List <$> replicateM (fromIntegral l) f + else do + i <- getWord8 + l <- + if i == 0xff + then getWord32be + else pure (fromIntegral i :: Word32) + List <$> replicateM (fromIntegral l) f + +getTuple :: Get a -> Get b -> Get (a, b) +getTuple f g = (,) <$> f <*> g + +getByteStringSized :: Get ByteString +getByteStringSized = do + size <- getInt64be + getByteString (fromIntegral size) + +getDictionary :: Int -> Get Dictionary +getDictionary ptr = do + offset <- bytesRead + skip $ ptr - fromIntegral offset + size <- fromIntegral <$> getInt64be + traceGet ("Dictionary size: " ++ show size) + dict <- Dictionary <$> V.replicateM size getByteStringSized + traceGet ("Dictionary: " ++ show dict) + return dict + +-- | Get a FastString +-- +-- FastStrings are stored in a global FastString table and only the index (a +-- Word32be) is stored at the expected position. +getCachedBS :: Dictionary -> Get ByteString +getCachedBS d = go =<< traceShow "Dict index:" getWord32be + where + go i = + case unDictionary d V.!? fromIntegral i of + Just bs -> pure bs + Nothing -> fail $ "Invalid dictionary index: " <> show i + +-- | Get Fingerprint +getFP' :: Get String +getFP' = do + x <- getWord64be + y <- getWord64be + return (showHex x (showHex y "")) + +getFP :: Get () +getFP = void getFP' + +getInterface721 :: Dictionary -> Get Interface +getInterface721 d = do + void getModule + void getBool + replicateM_ 2 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface741 :: Dictionary -> Get Interface +getInterface741 d = do + void getModule + void getBool + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface761 :: Dictionary -> Get Interface +getInterface761 d = do + void getModule + void getBool + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface781 :: Dictionary -> Get Interface +getInterface781 d = do + void getModule + void getBool + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface801 :: Dictionary -> Get Interface +getInterface801 d = do + void getModule + void getWord8 + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface821 :: Dictionary -> Get Interface +getInterface821 d = do + void getModule + void $ getMaybe getModule + void getWord8 + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = do + idType <- getWord8 + case idType of + 0 -> void $ getCachedBS d + _ -> + void $ + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + Module <$> getCachedBS d + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface841 :: Dictionary -> Get Interface +getInterface841 d = do + void getModule + void $ getMaybe getModule + void getWord8 + replicateM_ 5 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = do + idType <- getWord8 + case idType of + 0 -> void $ getCachedBS d + _ -> + void $ + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + Module <$> getCachedBS d + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface861 :: Dictionary -> Get Interface +getInterface861 d = do + void getModule + void $ getMaybe getModule + void getWord8 + replicateM_ 6 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = do + idType <- getWord8 + case idType of + 0 -> void $ getCachedBS d + _ -> + void $ + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + Module <$> getCachedBS d + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + getList (getCachedBS d) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterfaceRecent :: IfaceVersion -> Dictionary -> Get Interface +getInterfaceRecent version d = do + void $ traceShow "Module:" getModule + void $ traceShow "Sig:" $ getMaybe getModule + void getWord8 -- hsc_src + getFP -- iface_hash + getFP -- mod_hash + getFP -- flag_hash + getFP -- opt_hash + getFP -- hpc_hash + getFP -- plugin_hash + void getBool -- orphan + void getBool -- hasFamInsts + ddeps <- traceShow "Dependencies:" getDependencies + dusage <- traceShow "Usage:" getUsage + pure (Interface ddeps dusage) + where + since v = when (version >= v) + + getFastString = getCachedBS d + + getModule = do + idType <- traceShow "Unit type:" getWord8 + case idType of + 0 -> void getFastString + 1 -> + void $ + getFastString *> getList (getTuple getFastString getModule) + _ -> fail $ "Invalid unit type: " <> show idType + Module <$> getFastString + getDependencies = + withBlockPrefix $ do + if version >= V9041 + then do + -- warning: transitive dependencies are no longer stored, + -- only direct imports! + -- Modules are now prefixed with their UnitId (should have been + -- ModuleWithIsBoot...) + direct_mods <- traceShow "direct_mods:" $ + getList (getFastString *> getTuple getFastString getBool) + direct_pkgs <- getList getFastString + + -- plugin packages are now stored separately + plugin_pkgs <- getList getFastString + let all_pkgs = unList plugin_pkgs ++ unList direct_pkgs + + -- instead of a trust bool for each unit, we have an additional + -- list of trusted units (transitive) + trusted_pkgs <- getList getFastString + let trusted u = u `elem` unList trusted_pkgs + all_pkgs_trust = List (zip all_pkgs (map trusted all_pkgs)) + + -- these are new + _sig_mods <- getList getModule + _boot_mods <- getList (getFastString *> getTuple getFastString getBool) + + dep_orphs <- getList getModule + dep_finsts <- getList getModule + + -- plugin names are no longer stored here + let dep_plgins = List [] + + pure (Dependencies direct_mods all_pkgs_trust dep_orphs dep_finsts dep_plgins) + else do + dep_mods <- getList (getTuple getFastString getBool) + dep_pkgs <- getList (getTuple getFastString getBool) + dep_orphs <- getList getModule + dep_finsts <- getList getModule + dep_plgins <- getList getFastString + pure (Dependencies dep_mods dep_pkgs dep_orphs dep_finsts dep_plgins) + + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + -- this must follow the `Binary Usage` instance in GHC + -- (in GHC.Unit.Module.Deps, at least in GHC 9.4.5) + go :: Get (Maybe Usage) + go = do + usageType <- traceShow "Usage type:" getWord8 + case usageType of + 0 -> do + void (traceShow "Module:" getModule) -- usg_mod + void getFP -- usg_mod_hash + void getBool -- usg_safe + pure Nothing + + 1 -> do + void (traceShow "Home module:" getFastString) -- usg_mod_name + since V9045 $ void getFastString -- usg_unit_id + void getFP -- usg_mod_hash + void (getMaybe getFP) -- usg_exports + void getEntitiesList -- usg_entities + void getBool -- usg_safe + pure Nothing + + 2 -> do + -- usg_file_path + file_path <- traceShow "File:" $ if version >= V9081 + then Text.unpack . Text.decodeUtf8 <$> getFastString + else getString + void $ traceShow "FP:" getFP' -- usg_file_hash + since V9041 $ void $ traceShow "File label:" (getMaybe getString)-- usg_file_label + pure (Just (Usage file_path)) + + 3 -> do + void getModule -- usg_mod + void getFP -- usg_mod_hash + pure Nothing + + 4 | version >= V9041 -> do -- UsageHomeModuleInterface + void getFastString -- usg_mod_name + since V9045 $ void getFastString -- usg_unit_id + void getFP -- usg_iface_hash + pure Nothing + + _ -> fail $ "Invalid usageType: " <> show usageType + + getEntitiesList :: Get (List (ByteString, ())) + getEntitiesList = getList (getTuple (getNameSpace *> getFastString) getFP) + + -- See `instance Binary NameSpace` in module GHC.Types.Name.Occurrence. We + -- discard the information. + getNameSpace :: Get () + getNameSpace = if version >= V9081 + then do + nameSpaceType <- getWord8 + case nameSpaceType of + 0 -> pure () + 1 -> pure () + 2 -> pure () + 3 -> pure () + -- Unlike the original, we test that the byte we have obtained is + -- valid. + 4 -> do + void getFastString + _ -> fail $ "Invalid NameSpace type: " <> show nameSpaceType + else void getWord8 + +getInterface :: Get Interface +getInterface = do + let enableLEB128 = modify (\c -> c { useLEB128 = True}) + -- read a relative bin pointer + getRelPtr = do + c <- bytesRead + p <- getPtr + pure (fromIntegral c + p) + + magic <- lookAhead getWord32be >>= \case + -- normal magic + 0x1face -> getWord32be + 0x1face64 -> getWord32be + m -> do + -- GHC 8.10 mistakenly encoded header fields with LEB128 + -- so it gets special treatment + lookAhead (enableLEB128 >> getWord32be) >>= \case + 0x1face -> enableLEB128 >> getWord32be + 0x1face64 -> enableLEB128 >> getWord32be + _ -> fail $ "Invalid magic: " <> showHex m "" + + traceGet ("Magic: " ++ showHex magic "") + + -- empty field (removed in 9.0...) + case magic of + 0x1face -> do + e <- lookAhead getWord32be + if e == 0 + then void getWord32be + else enableLEB128 -- > 9.0 + 0x1face64 -> do + e <- lookAhead getWord64be + if e == 0 + then void getWord64be + else enableLEB128 -- > 9.0 + _ -> return () + + -- ghc version + version <- getString + traceGet ("Version: " ++ version) + + let !ifaceVersion + | version >= "9120" = V9120 + | version >= "9081" = V9081 + | version >= "9045" = V9045 + | version >= "9041" = V9041 + | version >= "9001" = V9001 + | version >= "8101" = V8101 + | version >= "8061" = V8061 + | version >= "8041" = V8041 + | version >= "8021" = V8021 + | version >= "8001" = V8001 + | version >= "7081" = V7081 + | version >= "7061" = V7061 + | version >= "7041" = V7041 + | version >= "7021" = V7021 + | otherwise = error $ "Unsupported version: " <> version + + -- way + way <- getString + traceGet ("Ways: " ++ show way) + + -- source hash (GHC >= 9.4) + when (ifaceVersion >= V9041) $ void getFP + + -- extensible fields (GHC >= 9.0) + when (ifaceVersion >= V9001) $ void getPtr + + -- dict_ptr + dictPtr <- if ifaceVersion >= V9120 -- 9.12 uses relative pointers + then getRelPtr + else getPtr + traceGet ("Dict ptr: " ++ show dictPtr) + + -- dict + dict <- lookAhead $ getDictionary $ fromIntegral dictPtr + + -- symtable_ptr + void getPtr + + -- IfaceType table + when (ifaceVersion >= V9120) $ void getPtr + + case ifaceVersion of + V9120 -> getInterfaceRecent ifaceVersion dict + V9081 -> getInterfaceRecent ifaceVersion dict + V9045 -> getInterfaceRecent ifaceVersion dict + V9041 -> getInterfaceRecent ifaceVersion dict + V9001 -> getInterfaceRecent ifaceVersion dict + V8101 -> getInterfaceRecent ifaceVersion dict + V8061 -> getInterface861 dict + V8041 -> getInterface841 dict + V8021 -> getInterface821 dict + V8001 -> getInterface801 dict + V7081 -> getInterface781 dict + V7061 -> getInterface761 dict + V7041 -> getInterface741 dict + V7021 -> getInterface721 dict + +fromFile :: FilePath -> IO (Either String Interface) +fromFile fp = withBinaryFile fp ReadMode go + where + go h = + let feed (G.Done _ _ iface) = pure $ Right iface + feed (G.Fail _ _ msg) = pure $ Left msg + feed (G.Partial k) = do + chunk <- hGetSome h defaultChunkSize + feed $ k $ if B.null chunk then Nothing else Just chunk + in feed $ runGetIncremental getInterface + + +getULEB128 :: forall a. (Integral a, FiniteBits a) => Get a +getULEB128 = + go 0 0 + where + go :: Int -> a -> Get a + go shift w = do + b <- getWord8 + let !hasMore = testBit b 7 + !val = w .|. (clearBit (fromIntegral b) 7 `unsafeShiftL` shift) :: a + if hasMore + then do + go (shift+7) val + else + return $! val + +getSLEB128 :: forall a. (Integral a, FiniteBits a) => Get a +getSLEB128 = 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 -> Get (a,Int,Bool) + go shift val = do + byte <- getWord8 + let !byteVal = fromIntegral (clearBit byte 7) :: a + !val' = val .|. (byteVal `unsafeShiftL` shift) + !more = testBit byte 7 + !shift' = shift+7 + if more + then go shift' val' + else do + let !signed = testBit byte 6 + return (val',shift',signed)
− test-files/iface/x64/ghc9027/Main.hi
binary file changed (1341 → absent bytes)
− test-files/iface/x64/ghc9027/X.hi
binary file changed (628 → absent bytes)
+ test-files/iface/x64/ghc9028/Main.hi view
binary file changed (absent → 1315 bytes)
+ test-files/iface/x64/ghc9028/X.hi view
binary file changed (absent → 628 bytes)
− test-files/iface/x64/ghc9063/Main.hi
binary file changed (2462 → absent bytes)
− test-files/iface/x64/ghc9063/X.hi
binary file changed (638 → absent bytes)
+ test-files/iface/x64/ghc9066/Main.hi view
binary file changed (absent → 2379 bytes)
+ test-files/iface/x64/ghc9066/X.hi view
binary file changed (absent → 639 bytes)
− test-files/iface/x64/ghc9081/Main.hi
binary file changed (2732 → absent bytes)
− test-files/iface/x64/ghc9081/X.hi
binary file changed (640 → absent bytes)
+ test-files/iface/x64/ghc9083/Main.hi view
binary file changed (absent → 2343 bytes)
+ test-files/iface/x64/ghc9083/X.hi view
binary file changed (absent → 640 bytes)
+ test-files/iface/x64/ghc9101/Main.hi view
binary file changed (absent → 2863 bytes)
+ test-files/iface/x64/ghc9101/X.hi view
binary file changed (absent → 721 bytes)
+ test-files/iface/x64/ghc9120/Main.hi view
binary file changed (absent → 2131 bytes)
+ test-files/iface/x64/ghc9120/X.hi view
binary file changed (absent → 736 bytes)
test/HiFileParserSpec.hs view
@@ -30,11 +30,13 @@ , "ghc8084" -- Last in GHC 8.8 series, using GHC 8.6.1 format , "ghc8107" -- Last in GHC 8.10 series, using GHC 8.10.1 format , "ghc9002" -- Last in GHC 9.0 series, using GHC 9.0.1 format - , "ghc9027" -- Last in GHC 9.2 series, using GHC 9.0.1 format + , "ghc9028" -- Last in GHC 9.2 series, using GHC 9.0.1 format , "ghc9044" -- Last using GHC 9.4.1 format , "ghc9047" -- Last in GHC 9.4 series, using GHC 9.4.5 format - , "ghc9063" -- Last in GHC 9.6 series, using GHC 9.4.5 format - , "ghc9081" -- First in GHC 9.8 series, using GHC 9.8.1 format + , "ghc9066" -- Last in GHC 9.6 series, using GHC 9.4.5 format + , "ghc9083" -- Last in GHC 9.8 series, using GHC 9.8.1 format + , "ghc9101" -- Last in GHC 9.10 series, using GHC 9.8.1 format + , "ghc9120" -- First in GHC 9.12 series, using GHC 9.12 format ] spec :: Spec