diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for hi-file-parser +## 0.1.2.0 + +Add support for GHC 8.10 and 9.0 [#2](https://github.com/commercialhaskell/hi-file-parser/pull/2) + ## 0.1.1.0 Add `NFData` instances diff --git a/hi-file-parser.cabal b/hi-file-parser.cabal --- a/hi-file-parser.cabal +++ b/hi-file-parser.cabal @@ -4,15 +4,15 @@ -- -- see: https://github.com/sol/hpack -- --- hash: af191a13968cedda5d64d117ea4e98f2223106716e965411a662809b08a5640c +-- hash: 683b7e0e97c0e1fcb98a9024ffc0a5f9051cd019a6f4d164f2c77d55a16f83c4 name: hi-file-parser -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Parser for GHC's hi files -description: Please see the README on Github at +description: Please see the README on Github at category: Development -homepage: https://github.com/commercialhaskell/stack#readme -bug-reports: https://github.com/commercialhaskell/stack/issues +homepage: https://github.com/commercialhaskell/hi-file-parser#readme +bug-reports: https://github.com/commercialhaskell/hi-file-parser/issues author: Hussein Ait-Lahcen maintainer: michael@snoyman.com license: BSD3 @@ -27,6 +27,12 @@ test-files/iface/x64/ghc822/X.hi test-files/iface/x64/ghc864/Main.hi test-files/iface/x64/ghc864/X.hi + test-files/iface/x64/ghc884/Main.hi + test-files/iface/x64/ghc884/X.hi + test-files/iface/x64/ghc8104/Main.hi + test-files/iface/x64/ghc8104/X.hi + test-files/iface/x64/ghc901/Main.hi + test-files/iface/x64/ghc901/X.hi test-files/iface/x32/ghc844/Main.hi test-files/iface/x32/ghc802/Main.hi test-files/iface/x32/ghc7103/Main.hi @@ -34,7 +40,7 @@ source-repository head type: git - location: https://github.com/commercialhaskell/stack + location: https://github.com/commercialhaskell/hi-file-parser library exposed-modules: @@ -48,6 +54,7 @@ base >=4.10 && <5 , binary , bytestring + , mtl , rio , vector default-language: Haskell2010 @@ -67,6 +74,7 @@ , bytestring , hi-file-parser , hspec + , mtl , rio , vector default-language: Haskell2010 diff --git a/src/HiFileParser.hs b/src/HiFileParser.hs --- a/src/HiFileParser.hs +++ b/src/HiFileParser.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} module HiFileParser ( Interface(..) @@ -16,8 +19,8 @@ {- HLINT ignore "Reduce duplication" -} import Control.Monad (replicateM, replicateM_) -import Data.Binary (Get, Word32) -import Data.Binary.Get (Decoder (..), bytesRead, +import Data.Binary (Word64,Word32,Word8) +import qualified Data.Binary.Get as G (Get, Decoder (..), bytesRead, getByteString, getInt64be, getWord32be, getWord64be, getWord8, lookAhead, @@ -33,9 +36,75 @@ import GHC.IO.IOMode (IOMode (..)) import Numeric (showHex) import RIO.ByteString as B (ByteString, hGetSome, null) -import RIO (Generic, NFData) +import RIO (Int64,Generic, NFData) import System.IO (withBinaryFile) +import Data.Bits (FiniteBits(..),testBit, + unsafeShiftL,(.|.),clearBit, + complement) +import Control.Monad.State +import qualified Debug.Trace +newtype IfaceGetState = IfaceGetState + { useLEB128 :: Bool -- ^ Use LEB128 encoding for numbers + } + +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 @@ -73,7 +142,7 @@ -- | Read a block prefixed with its length withBlockPrefix :: Get a -> Get a -withBlockPrefix f = getWord32be *> f +withBlockPrefix f = getPtr *> f getBool :: Get Bool getBool = toEnum . fromIntegral <$> getWord8 @@ -86,12 +155,18 @@ getList :: Get a -> Get (List a) getList f = do - i <- getWord8 - l <- - if i == 0xff - then getWord32be - else pure (fromIntegral i :: Word32) - List <$> replicateM (fromIntegral l) f + 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 @@ -106,18 +181,28 @@ offset <- bytesRead skip $ ptr - fromIntegral offset size <- fromIntegral <$> getInt64be - Dictionary <$> V.replicateM size getByteStringSized + traceGet ("Dictionary size: " ++ show size) + dict <- Dictionary <$> V.replicateM size getByteStringSized + traceGet ("Dictionary: " ++ show dict) + return dict getCachedBS :: Dictionary -> Get ByteString -getCachedBS d = go =<< getWord32be +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 $ getWord64be *> getWord64be +getFP = void getFP' getInterface721 :: Dictionary -> Get Interface getInterface721 d = do @@ -394,27 +479,103 @@ 3 -> getModule *> getFP $> Nothing _ -> fail $ "Invalid usageType: " <> show usageType +getInterface8101 :: Dictionary -> Get Interface +getInterface8101 d = do + void $ traceShow "Module:" getModule + void $ traceShow "Sig:" $ getMaybe getModule + void getWord8 + replicateM_ 6 getFP + void getBool + void getBool + Interface <$> traceShow "Dependencies:" getDependencies <*> traceShow "Usage:" getUsage + where + getModule = do + idType <- traceShow "Unit type:" getWord8 + case idType of + 0 -> void $ getCachedBS d + 1 -> + void $ + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + _ -> fail $ "Invalid unit type: " <> show idType + 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 <- traceShow "Usage type:" getWord8 + case usageType of + 0 -> traceShow "Module:" getModule *> getFP *> getBool $> Nothing + 1 -> + traceShow "Home module:" (getCachedBS d) *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> traceShow "File:" getString <* traceShow "FP:" getFP' + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + getInterface :: Get Interface getInterface = do - magic <- getWord32be + 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 - -- x32 - 0x1face -> void getWord32be - -- x64 - 0x1face64 -> void getWord64be - invalidMagic -> fail $ "Invalid magic: " <> showHex invalidMagic "" + 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) + -- way - void getString + way <- getString + traceGet ("Ways: " ++ show way) + + -- extensible fields (GHC > 9.0) + when (version >= "9001") $ void getPtr + -- dict_ptr - dictPtr <- getWord32be + dictPtr <- getPtr + traceGet ("Dict ptr: " ++ show dictPtr) + -- dict dict <- lookAhead $ getDictionary $ fromIntegral dictPtr + -- symtable_ptr - void getWord32be + void getPtr let versions = - [ ("8061", getInterface861) + [ ("8101", getInterface8101) + , ("8061", getInterface861) , ("8041", getInterface841) , ("8021", getInterface821) , ("8001", getInterface801) @@ -427,13 +588,50 @@ Just f -> f dict Nothing -> fail $ "Unsupported version: " <> version + fromFile :: FilePath -> IO (Either String Interface) fromFile fp = withBinaryFile fp ReadMode go where go h = - let feed (Done _ _ iface) = pure $ Right iface - feed (Fail _ _ msg) = pure $ Left msg - feed (Partial k) = do + 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 + 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) diff --git a/test-files/iface/x64/ghc8104/Main.hi b/test-files/iface/x64/ghc8104/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc8104/Main.hi differ diff --git a/test-files/iface/x64/ghc8104/X.hi b/test-files/iface/x64/ghc8104/X.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc8104/X.hi differ diff --git a/test-files/iface/x64/ghc884/Main.hi b/test-files/iface/x64/ghc884/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc884/Main.hi differ diff --git a/test-files/iface/x64/ghc884/X.hi b/test-files/iface/x64/ghc884/X.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc884/X.hi differ diff --git a/test-files/iface/x64/ghc901/Main.hi b/test-files/iface/x64/ghc901/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc901/Main.hi differ diff --git a/test-files/iface/x64/ghc901/X.hi b/test-files/iface/x64/ghc901/X.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc901/X.hi differ diff --git a/test/HiFileParserSpec.hs b/test/HiFileParserSpec.hs --- a/test/HiFileParserSpec.hs +++ b/test/HiFileParserSpec.hs @@ -18,10 +18,10 @@ versions32 = ["ghc7103", "ghc802", "ghc822", "ghc844"] versions64 :: [Version] -versions64 = ["ghc822", "ghc844", "ghc864"] +versions64 = ["ghc822", "ghc844", "ghc864", "ghc884", "ghc8104", "ghc901"] spec :: Spec -spec = describe "should succesfully deserialize x32 interface for" $ do +spec = describe "should succesfully deserialize interface for" $ do traverse_ (deserialize check32) (("x32/" <>) <$> versions32) traverse_ (deserialize check64) (("x64/" <>) <$> versions64)