From adcb42a615ca00db8e0216c9cf25b65c33a7f588 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Thu, 11 Aug 2022 11:39:08 +0200 Subject: [PATCH] Add support for GHC 9.4 --- package.yaml | 4 + src/HiFileParser.hs | 172 +++++++++++++++++++++------ stack.yaml.lock | 8 +- test-files/iface/x64/ghc9023/Main.hi | Bin 0 -> 1326 bytes test-files/iface/x64/ghc9023/X.hi | Bin 0 -> 625 bytes test-files/iface/x64/ghc9041/Main.hi | Bin 0 -> 2478 bytes test-files/iface/x64/ghc9041/X.hi | Bin 0 -> 639 bytes test/HiFileParserSpec.hs | 18 ++- 8 files changed, 158 insertions(+), 44 deletions(-) create mode 100644 test-files/iface/x64/ghc9023/Main.hi create mode 100644 test-files/iface/x64/ghc9023/X.hi create mode 100644 test-files/iface/x64/ghc9041/Main.hi create mode 100644 test-files/iface/x64/ghc9041/X.hi diff --git a/package.yaml b/package.yaml index 4ff84e9..f989ce6 100644 --- a/package.yaml +++ b/package.yaml @@ -20,6 +20,10 @@ extra-source-files: - test-files/iface/x64/ghc8104/X.hi - test-files/iface/x64/ghc901/Main.hi - test-files/iface/x64/ghc901/X.hi +- test-files/iface/x64/ghc9023/Main.hi +- test-files/iface/x64/ghc9023/X.hi +- test-files/iface/x64/ghc9041/Main.hi +- test-files/iface/x64/ghc9041/X.hi - test-files/iface/x32/ghc844/Main.hi - test-files/iface/x32/ghc802/Main.hi - test-files/iface/x32/ghc7103/Main.hi diff --git a/src/HiFileParser.hs b/src/HiFileParser.hs index 1cce86d..849e9db 100644 --- a/src/HiFileParser.hs +++ b/src/HiFileParser.hs @@ -48,6 +48,22 @@ newtype IfaceGetState = IfaceGetState { useLEB128 :: Bool -- ^ Use LEB128 encoding for numbers } +data IfaceVersion + = V7021 + | V7041 + | V7061 + | V7081 + | V8001 + | V8021 + | V8041 + | V8061 + | V8101 + | V9001 + | V9041 + deriving (Show,Eq,Ord,Enum) + -- careful, the Ord matters! + + type Get a = StateT IfaceGetState G.Get a enableDebug :: Bool @@ -56,7 +72,7 @@ enableDebug = False traceGet :: String -> Get () traceGet s | enableDebug = Debug.Trace.trace s (return ()) - | otherwise = return () + | otherwise = return () traceShow :: Show a => String -> Get a -> Get a traceShow s g @@ -479,15 +495,22 @@ getInterface861 d = do 3 -> getModule *> getFP $> Nothing _ -> fail $ "Invalid usageType: " <> show usageType -getInterface8101 :: Dictionary -> Get Interface -getInterface8101 d = do +getInterfaceRecent :: IfaceVersion -> Dictionary -> Get Interface +getInterfaceRecent version 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 + 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 getModule = do idType <- traceShow "Unit type:" getWord8 @@ -499,26 +522,83 @@ getInterface8101 d = do _ -> 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) + 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 (getCachedBS d *> getTuple (getCachedBS d) getBool) + direct_pkgs <- getList (getCachedBS d) + + -- plugin packages are now stored separately + plugin_pkgs <- getList (getCachedBS d) + 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 (getCachedBS d) + let trusted u = elem u (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 (getCachedBS d *> getTuple (getCachedBS d) 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 (getCachedBS d) getBool) + dep_pkgs <- getList (getTuple (getCachedBS d) getBool) + dep_orphs <- getList getModule + dep_finsts <- getList getModule + dep_plgins <- getList (getCachedBS d) + pure (Dependencies dep_mods dep_pkgs dep_orphs dep_finsts dep_plgins) + 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 + 0 -> do + void (traceShow "Module:" getModule) + void getFP + void getBool + pure Nothing + + 1 -> do + void (traceShow "Home module:" (getCachedBS d)) + void getFP + void (getMaybe getFP) + void (getList (getTuple (getWord8 *> getCachedBS d) getFP)) + void getBool + pure Nothing + + 2 -> do + file_path <- traceShow "File:" getString + _file_hash <- traceShow "FP:" getFP' + when (version >= V9041) $ do + _file_label <- traceShow "File label:" (getMaybe getString) + pure () + pure (Just (Usage file_path)) + + 3 -> do + void getModule + void getFP + pure Nothing + + 4 | version >= V9041 -> do -- UsageHomeModuleInterface + _mod_name <- void (getCachedBS d) + _iface_hash <- void getFP + pure Nothing + _ -> fail $ "Invalid usageType: " <> show usageType getInterface :: Get Interface @@ -557,12 +637,29 @@ getInterface = do version <- getString traceGet ("Version: " ++ version) + let !ifaceVersion + | 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) - -- extensible fields (GHC > 9.0) - when (version >= "9001") $ void getPtr + -- source hash (GHC >= 9.4) + when (ifaceVersion >= V9041) $ void getFP + + -- extensible fields (GHC >= 9.0) + when (ifaceVersion >= V9001) $ void getPtr -- dict_ptr dictPtr <- getPtr @@ -573,20 +670,19 @@ getInterface = do -- symtable_ptr void getPtr - let versions = - [ ("8101", getInterface8101) - , ("8061", getInterface861) - , ("8041", getInterface841) - , ("8021", getInterface821) - , ("8001", getInterface801) - , ("7081", getInterface781) - , ("7061", getInterface761) - , ("7041", getInterface741) - , ("7021", getInterface721) - ] - case snd <$> find ((version >=) . fst) versions of - Just f -> f dict - Nothing -> fail $ "Unsupported version: " <> version + + case ifaceVersion of + 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) diff --git a/stack.yaml.lock b/stack.yaml.lock index a58f87f..7af0442 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 519764 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2019/7/15.yaml - sha256: 3f93a8081b0d3e6ee2b463886b1cc9f60403fae8a2eaeab4701b6e6150dfc98d - original: nightly-2019-07-15 + size: 590100 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml + sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 + original: lts-18.28 diff --git a/test-files/iface/x64/ghc9023/Main.hi b/test-files/iface/x64/ghc9023/Main.hi new file mode 100644 index 0000000000000000000000000000000000000000..0e9956929931461bb1c964e00ca9330d8790a593 GIT binary patch literal 1326 zcmZ`%ZA?>F7(S<$QmRx@=h$F#ZrPtL;g;b3knE2iAS4ntA;w=@F736wTYGPF@2!J> z4bVZyhqL8FQO1WrVSFk9x~Y`{A~HdUgp@B4oKglObc)Iv>dtAWiOF`7`{q2)`=0mf zKJf2Rbx3?{+yMZ9GzI`78GZ2pKmgox3l6Jgy8iP8N6Gxq^q&tEd1C`}*V{cU{Dh@u zaBI45mUA`zQd!oM+Zx+BJl@=0TeS35OKEL!=hBm|oog+98zwrGT8n%m@OIy=uGZ`y3tC}b@16XDW_!gU)Byl9Py(a`2mw+M3S>Y6h%i9NcL8D> zAhrV{91sdX>;S}0Ktuon@w)-B2M})oVlN=x21F!~z5}H10$CJFCNYMiY2=Fw7dI^a zpJ!I!pnYKRa(}8(o#-(I^3s?YmPoIaD!GpR*2o7OSV$%B=Px+=}dj&9z?}hy2++S7HBH zLDP6u$J4TaBdT<{)-gWuqV7{y*WgT(?P>cU1d`BnS`bO?)Vb=7N0;rtw?m(~@tW<2 zv&+3u(hHPYPERYfLY6KrR!M5KDx*P(tTLXABM&HbOa?|VLBy~sol#9=<}}R<49Ak% z(hhI;X6_#qXQ12SY^bx|^?WIbQW^zb`6^lv)v6c+Ppj!uq}JxTxpm%syS*HmYg(s@ zC#zdg7xLo?2alvAkb1SXD*xr9CoTR@`Yw(1JMzoDedrhC0}HK|yx&&Fp524nv|aPwH}~dT+4rwYiT$5p6AuVneSe?@Y(D%bL{BknND4CWWJm@j(A)5q zGZ+nP)b9#hIZlibwZX-QVaC8S`UsKM8+4RN$7m_xTUw`+A5A(;Ch9m!48ylWDAS(9 z94qpijyz~E=ol3xGN)<9YmVo+?{*)dM2bu_vMQ0|N#qj5y>C#-YMK=pF>8B(P2pIM zQSS)c(`Y@T;W?ur@=Zu4vm(v2lui-g)3XdTnaZof1L#ChEAk*fxdOc=WQsyKZu%(A z(mbOQA}~l!B@;4Lv_VATQefhEdKwy#(g=|lC2~BCmXyY;j!~?J#C4)EkCBnm&?qU* zVqppaU(_p}ObYIcOiv=yvRIMIlzqX|Sj_UYECFp56%OnYXA~m;>)A0TWB>o~ucwEn Oz(j#HQy2AZe*SqY|GPDZzIJx> z@4La+d2ri@`&$>@naucc-?e`&lX`!jWjuN4_|~;e6S~(jwjVgt(Y<>4EGM877#I#R zFf%bQGq5l)F)*<*FtKqlFtIZ*aWF7(GB5$z+zd=S3{1QXOneMX{0vM2AT9TRj%5;T znEq|YgDb0_zhS(4d&j*cM<2XQ2l;~G1iaWLdH-rnFbuthC*|w~qc- z5TsCAz&b%t1QZHLc?^NVc!Lj+mkX)eFfjXNWEU2o8J|o0)S@*z^NGh82~^4bo2Vk)VQ&xL1hw(x}PspOeH<;d_2-FRzH=psxRX?~tbz{a{;#pbX$of$^fG;4L&OiB9y{-z+X z0|a63fC&N+j(~6i_Ri}8!2`r9K&%FY3m{wpu?7%p0pSLSb$~$94S?7Ph)sa_01)nA z^M_#b7T~ZI0LSr-$d2Qnel*N7o7oWxv)k&zb+=<9ucH_N@lj0O-4ShT=llqqESt9V zzKjh|;RGKyXnS-2(xmsuuQkqhx3^V??LhkW+v@HoBqzj{cGbh^p+2iluWA1rK)YB= zXm^IC+yJZJ($ZkQ2f3H@ zz!7thkc^^eCMCIlCOf4QJ{bBluESOz)w7aL1WJSCs$c~2m+v}JoR&DGExI%4-I0E= zs<>dl(1?6^-;c`y5h!FRK1z+R(JL>*;hrfpuh}}Ce5`4ry!~cpA}I(U(LmOIf@curfkkW_RArX<%^#Js9IT8 zjeI~!N$!64F$%MEcOF$mX4_yx^3{jN>Ue_>u$x^8AXq9`DHF03Um|3FqGU4uF47Yf z>T*a5!`r*77LAuU;q}q6sD4XI*)YW2*2xVo zXka8=XlRNbHe^;q)A?(OO>HI{PAnw*#-SrrV|C`H;mB~2NAc-irpeXvj}xA#K}{N5f{sq^ce<@RrIoDcc#C-)&09^UxK z6hhVo?~b7cM;;7eH|$r)Sy~|@y_HItR3v1jrzqDqJepSgvi5+G6_Vb#0LXo6mRirz zJ}SA0RnR0-W!O#2Sck=woRzZb)g0GPAy-JnYq-5X6)X*+6)L6sa*{kOXDM1Pl(};J z0JV}LkJ4fnj{0tCr0|vqWQ+6v5GAK*sfcmI!5lt{LJ?6)7LA@&9D_L`Wms3dJs#kX z!WITG>o7*kdWk!h`zUA%^;v&fbVMi*BJtf@F&|SZVGxBdqU3m{F`R76Yd-0_lzn7? zFX^wAv%(OkV>E^5AkSaTpl3i{ahPL^jQf8bJ0cC-{y+RTh`^J)oh;~cnAZB2Azqf16 zja%2I$@DH=v-fP@fknF*`*$>6Te@S{+G&g%=AQd<=*OQIXBp3Q%>4dl!Nsc=7$4p~ z_2kOcN3)hNF1zq(>E&IGT}K!@KCbFt{_eq<#Lk1;KHT5B@Xln$kNd9uYnjyh`z+(h zL&vwSZJN-%ma+Z7nU3z&%V#+;fWS=#MkWx=%)kUhEDWq{TntR?3``shOq>i%KsGl6 z6AuFuF9Q=F0~0?3lK@cdcc6=z1bYr$eA#jC@}HNCA9sHKck_FH%REMqUl?w#zx82l z)70m47&o5V@b$*q|I2wmHZY2U2q^}pb=zJ{eK+^eYp1n`CN4N}`TzAKkTym;)=P~I z&p5#0aqZ>T$D1B4eW%+0WZS$Y`&$?FfedC~Ok&;808;}N$YePF^ZUz|`^)BMuG{nR zUh9G8O>!U!2B4=H8H7NDun0?TVrCv=1WQt4aVm$qhqIm&kiiLJxaH(0mT;tJBdL=;8HGbJ^zB(tQF8!YOZpO>GRA`WH;r{-p+7v+~0=y~Rqq!#5R=J0~WLn;eW z_56!cz%Fr5%}XuHOfD7xIm^=@=&0n>f|AVqJYJAMP)IP)`HAVp>;XloIi)G7j1`