September 2025 - ghc-commits

[Git][ghc/ghc][wip/shorter-this-module-links] Use showUnique in internalAnchorIdent
by Oleg Grenrus (＠phadej) 14 Sep '25

14 Sep '25

Oleg Grenrus pushed to branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC Commits: b520943e by Oleg Grenrus at 2025-09-14T19:15:25+03:00 Use showUnique in internalAnchorIdent Showing the key of Unique as a number is generally not a great idea. GHC Unique has a tag in high bits, so the raw number is unnecessarily big. So now we have ```html <a href="#l-rvgK">bar</a> ``` instead of ```html <a href="#local-6989586621679015689">bar</a> ``` Together with previous changes of shorter intra-module links the effect on compressed files is not huge, that is expected as we simply remove repetitive contents which pack well. ``` 12_694_206 Agda-2.9.0-docs-orig.tar.gz 12_566_065 Agda-2.9.0-docs.tar.gz ``` However when unpacked, the difference can be significant, e.g. Agda's largest module source got 5% reduction: ``` 14_230_117 Agda.Syntax.Parser.Parser.html 13_422_109 Agda.Syntax.Parser.Parser.html ``` The whole hyperlinked source code directory got similar reduction ``` 121M Agda-2.9.0-docs-orig/src 114M Agda-2.9.0-docs/src ``` For the reference, sources are about 2/3 of the generated haddocks ``` 178M Agda-2.9.0-docs-old 172M Agda-2.9.0-docs ``` so we get around 3.5% size reduction overall. Not bad for a small local changes. - - - - - 1 changed file: - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs Changes: ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -14,7 +14,7 @@ import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext) import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique) import GHC.Types.SrcLoc -import GHC.Types.Unique (getKey) +import GHC.Types.Unique (showUnique) import GHC.Unit.Module (Module, ModuleName, moduleNameString) import GHC.Utils.Encoding (utf8DecodeByteString) import System.FilePath.Posix ((</>)) @@ -254,7 +254,7 @@ externalAnchorIdent :: Name -> String externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: Name -> String -internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique +internalAnchorIdent = ("l-" ++) . showUnique . nameUnique -- | Generate the HTML hyperlink for an identifier hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b520943e5c5581eb5be0b3e42096788… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b520943e5c5581eb5be0b3e42096788… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/shorter-this-module-links] Use showUnique in internalAnchorIdent
by Oleg Grenrus (＠phadej) 14 Sep '25

14 Sep '25

Oleg Grenrus pushed to branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC Commits: 4d5bccf8 by Oleg Grenrus at 2025-09-14T18:46:13+03:00 Use showUnique in internalAnchorIdent Showing the key of Unique as a number is generally not a great idea. GHC Unique has a tag in high bits, so the raw number is unnecessarily big. So now we have ```html <a href="#l-rvgK">bar</a> ``` instead of ```html <a href="#local-6989586621679015689">bar</a> ``` Together with previous changes of shorter intra-module links the effect on compressed files is not huge, that is expected as we simply remove repetitive contents which pack well. ``` 12_694_206 Agda-2.9.0-docs-orig.tar.gz 12_566_065 Agda-2.9.0-docs.tar.gz ``` However when unpacked, the difference can be significant, e.g. Agda's largest module source got 5% reduction: ``` 14_230_117 Agda.Syntax.Parser.Parser.html 13_422_109 Agda.Syntax.Parser.Parser.html ``` The whole hyperlinked source code directory got similar reduction ``` 121M Agda-2.9.0-docs-orig/src 114M Agda-2.9.0-docs/src ``` For the reference, sources are about 2/3 of the generated haddocks ``` 178M Agda-2.9.0-docs-old 172M Agda-2.9.0-docs ``` so we get around 3.5% size reduction overall. Not bad for a small local changes. - - - - - 24 changed files: - libffi-tarballs - libraries/Cabal - libraries/Win32 - libraries/array - libraries/containers - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/filepath - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/terminfo - libraries/text - libraries/time - libraries/unix - nofib - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/hpc - utils/hsc2hs Changes: ===================================== libffi-tarballs ===================================== @@ -1 +1 @@ -Subproject commit 7c51059557b68d29820a0a87cebfa6fe73c8adf5 +Subproject commit 89a9b01c5647c8f0d3899435b99df690f582e9f1 ===================================== libraries/Cabal ===================================== @@ -1 +1 @@ -Subproject commit d9b0904b49dc84e0bfc79062daf2bbdf9d22a422 +Subproject commit 269fd808e5d80223a229b6b19edfe6f5b109007a ===================================== libraries/Win32 ===================================== @@ -1 +1 @@ -Subproject commit 7d0772bb265a6c59eb14c441cf65c778895528df +Subproject commit 027cbcf0de25d681823ea92fb545a2604c3a6a8b ===================================== libraries/array ===================================== @@ -1 +1 @@ -Subproject commit 6d59d5deb4f2a12656ab4c4371c0d12dac4875ef +Subproject commit e7ffb82fd40134da21d7642a41568f32c77c1a04 ===================================== libraries/containers ===================================== @@ -1 +1 @@ -Subproject commit 801b06e5d4392b028e519d5ca116a2881d559721 +Subproject commit 4fda06c43ea14f808748aa8988158946c3ce0caf ===================================== libraries/deepseq ===================================== @@ -1 +1 @@ -Subproject commit ae2762ac241a61852c9ff4c287af234fb1ad931f +Subproject commit af115cc226cc87fba89d0f6e2e9212e755c24983 ===================================== libraries/directory ===================================== @@ -1 +1 @@ -Subproject commit 6442a3cf04f74d82cdf8c9213324313d52b23d28 +Subproject commit 005fa061171a55d35ce8dfe936cf3703525a8616 ===================================== libraries/exceptions ===================================== @@ -1 +1 @@ -Subproject commit b6c4290124eb1138358bf04ad9f33e67f6c5c1d8 +Subproject commit 8e55b720f45db91f4895f710863ef9dbc10fe569 ===================================== libraries/filepath ===================================== @@ -1 +1 @@ -Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe +Subproject commit 65b0f8f31aac4a306135e27734988327f8eb1e6f ===================================== libraries/haskeline ===================================== @@ -1 +1 @@ -Subproject commit 991953cd5d3bb9e8057de4a0d8f2cae3455865d8 +Subproject commit 5f4bf62bf1f4846ad0b8d1fa9d45f902e3934511 ===================================== libraries/hpc ===================================== @@ -1 +1 @@ -Subproject commit 12675279dc5cbea4ade8b5157b080390d598f03f +Subproject commit f321056015dc36b454f323ca4285d684f4f782d3 ===================================== libraries/os-string ===================================== @@ -1 +1 @@ -Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1 +Subproject commit 4b5efedcd2da9314edda80d973a44e67020370db ===================================== libraries/parsec ===================================== @@ -1 +1 @@ -Subproject commit 552730e23e1fd2dae46a60d75138b8d173492462 +Subproject commit b87122c1c74b8240e65044a8f600f0427d4dd9c3 ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit ae50731b5fb221a7631f7e9d818fc6716c85c51e +Subproject commit 9c3bfc214c72bbd0c8a30a1c41465deed0feaf47 ===================================== libraries/semaphore-compat ===================================== @@ -1 +1 @@ -Subproject commit ba87d1bb0209bd9f29bda1c878ddf345f8a2b199 +Subproject commit 54882cd9a07322a4cf95d4fc0627107eaf1eb051 ===================================== libraries/stm ===================================== @@ -1 +1 @@ -Subproject commit 23bdcc2319965911af28542e76fc01f37c107d40 +Subproject commit def18948f42a2eb8c34efdf65f7e614d1f6d5703 ===================================== libraries/terminfo ===================================== @@ -1 +1 @@ -Subproject commit 16db154e3e97e6bff62329574163851a7090f3b6 +Subproject commit 788ce671cb1cec54c3c9b3ac1c1ba189e8424819 ===================================== libraries/text ===================================== @@ -1 +1 @@ -Subproject commit 5f343f668f421bfb30cead594e52d0ac6206ff67 +Subproject commit b86564cae8d7262c7c4e7afe7a9163c83de3f175 ===================================== libraries/time ===================================== @@ -1 +1 @@ -Subproject commit 507f50844802f1469ba6cadfeefd4e3fecee0416 +Subproject commit e5c5d1987011efe88a21ab6ded45aaa33a16274f ===================================== libraries/unix ===================================== @@ -1 +1 @@ -Subproject commit c9b3e95b5c15b118e55522bd92963038c6a88160 +Subproject commit 74ae1c0d9dd1518434f7d6cd3e63d7769599e0f9 ===================================== nofib ===================================== @@ -1 +1 @@ -Subproject commit b7391df4540ac8b11b35e1b2e2c15819b5171798 +Subproject commit da7eed00e494aba1da9f51cb92089ca10e2454e7 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -14,7 +14,7 @@ import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext) import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique) import GHC.Types.SrcLoc -import GHC.Types.Unique (getKey) +import GHC.Types.Unique (showUnique) import GHC.Unit.Module (Module, ModuleName, moduleNameString) import GHC.Utils.Encoding (utf8DecodeByteString) import System.FilePath.Posix ((</>)) @@ -254,7 +254,7 @@ externalAnchorIdent :: Name -> String externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: Name -> String -internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique +internalAnchorIdent = ("l-" ++) . showUnique . nameUnique -- | Generate the HTML hyperlink for an identifier hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html ===================================== utils/hpc ===================================== @@ -1 +1 @@ -Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5 +Subproject commit d1780eb21c1e5a1227fff80c8d325d5142f04255 ===================================== utils/hsc2hs ===================================== @@ -1 +1 @@ -Subproject commit fe3990b9f35000427b016a79330d9f195587cad8 +Subproject commit c3b21800a67366c9591dc85a471d1dfdb1efcf29 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d5bccf8863a264fa9d4b9c5dd666e1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d5bccf8863a264fa9d4b9c5dd666e1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/shorter-this-module-links] Use showUnique in internalAnchorIdent
by Oleg Grenrus (＠phadej) 14 Sep '25

14 Sep '25

Oleg Grenrus pushed to branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC Commits: 7b31a55f by Oleg Grenrus at 2025-09-14T19:10:45+03:00 Use showUnique in internalAnchorIdent Showing the key of Unique as a number is generally not a great idea. GHC Unique has a tag in high bits, so the raw number is unnecessarily big. So now we have ```html <a href="#l-rvgK">bar</a> ``` instead of ```html <a href="#local-6989586621679015689">bar</a> ``` Together with previous changes of shorter intra-module links the effect on compressed files is not huge, that is expected as we simply remove repetitive contents which pack well. ``` 12_694_206 Agda-2.9.0-docs-orig.tar.gz 12_566_065 Agda-2.9.0-docs.tar.gz ``` However when unpacked, the difference can be significant, e.g. Agda's largest module source got 5% reduction: ``` 14_230_117 Agda.Syntax.Parser.Parser.html 13_422_109 Agda.Syntax.Parser.Parser.html ``` The whole hyperlinked source code directory got similar reduction ``` 121M Agda-2.9.0-docs-orig/src 114M Agda-2.9.0-docs/src ``` For the reference, sources are about 2/3 of the generated haddocks ``` 178M Agda-2.9.0-docs-old 172M Agda-2.9.0-docs ``` so we get around 3.5% size reduction overall. Not bad for a small local changes. - - - - - 7 changed files: - libffi-tarballs - nofib - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs - utils/hpc - utils/hsc2hs Changes: ===================================== libffi-tarballs ===================================== @@ -1 +1 @@ -Subproject commit 7c51059557b68d29820a0a87cebfa6fe73c8adf5 +Subproject commit 89a9b01c5647c8f0d3899435b99df690f582e9f1 ===================================== nofib ===================================== @@ -1 +1 @@ -Subproject commit b7391df4540ac8b11b35e1b2e2c15819b5171798 +Subproject commit da7eed00e494aba1da9f51cb92089ca10e2454e7 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -80,7 +80,6 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do nc <- freshNameCache HieFile { hie_hs_file = file - , hie_module = thisModule , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc @@ -117,7 +116,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens' -- Produce and write out the hyperlinked sources - writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens + writeUtf8File path . renderToString pretty . render' fullAst $ tokens where dflags = ifaceDynFlags iface sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle @@ -129,7 +128,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do False -- lex Haddocks as comment tokens True -- produce comment tokens False -- produce position pragmas tokens - render' thisModule = render thisModule (Just srcCssFile) (Just highlightScript) srcs + render' = render (Just srcCssFile) (Just highlightScript) srcs path = srcdir </> hypSrcModuleFile (ifaceMod iface) emptyHieAst fileFs = ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -15,7 +15,7 @@ import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext) import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique) import GHC.Types.SrcLoc import GHC.Types.Unique (getKey) -import GHC.Unit.Module (Module, ModuleName, moduleNameString) +import GHC.Unit.Module (ModuleName, moduleNameString) import GHC.Utils.Encoding (utf8DecodeByteString) import System.FilePath.Posix ((</>)) import Text.XHtml (Html, HtmlAttr, (!)) @@ -28,9 +28,7 @@ type StyleClass = String -- | Produce the HTML corresponding to a hyperlinked Haskell source render - :: Module - -- ^ this module - -> Maybe FilePath + :: Maybe FilePath -- ^ path to the CSS file -> Maybe FilePath -- ^ path to the JS file @@ -41,12 +39,12 @@ render -> [Token] -- ^ tokens to render -> Html -render thisModule mcss mjs srcs ast tokens = header mcss mjs <> body thisModule srcs ast tokens +render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens -body :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html -body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc +body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html +body srcs ast tokens = Html.body . Html.pre $ hypsrc where - hypsrc = renderWithAst thisModule srcs ast tokens + hypsrc = renderWithAst srcs ast tokens header :: Maybe FilePath -> Maybe FilePath -> Html header Nothing Nothing = Html.noHtml @@ -77,9 +75,9 @@ splitTokens ast toks = (before, during, after) -- | Turn a list of tokens into hyperlinked sources, threading in relevant link -- information from the 'HieAST'. -renderWithAst :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html -renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of - [tok] | nodeSpan == tkSpan tok -> richToken thisModule srcs nodeInfo tok +renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html +renderWithAst srcs Node{..} toks = anchored $ case toks of + [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators -- as multiple tokens. -- @@ -94,7 +92,6 @@ renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken - thisModule srcs nodeInfo ( Token @@ -107,7 +104,6 @@ renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken - thisModule srcs nodeInfo ( Token @@ -122,7 +118,7 @@ renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of go _ [] = mempty go [] xs = foldMap renderToken xs go (cur : rest) xs = - foldMap renderToken before <> renderWithAst thisModule srcs cur during <> go rest after + foldMap renderToken before <> renderWithAst srcs cur during <> go rest after where (before, during, after) = splitTokens cur xs anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo) @@ -141,8 +137,8 @@ renderToken Token{..} tokenSpan = Html.thespan (Html.toHtml tkValue') -- | Given information about the source position of definitions, render a token -richToken :: Module -> SrcMaps -> NodeInfo PrintedType -> Token -> Html -richToken thisModule srcs details Token{..} +richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html +richToken srcs details Token{..} | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' | otherwise = annotate details $ linked content where @@ -159,7 +155,7 @@ richToken thisModule srcs details Token{..} -- If we have name information, we can make links linked = case identDet of - Just (n, _) -> hyperlink thisModule srcs n + Just (n, _) -> hyperlink srcs n Nothing -> id -- | Remove CRLFs from source @@ -257,8 +253,8 @@ internalAnchorIdent :: Name -> String internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique -- | Generate the HTML hyperlink for an identifier -hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html -hyperlink thisModule (srcs, srcs') ident = case ident of +hyperlink :: SrcMaps -> Identifier -> Html -> Html +hyperlink (srcs, srcs') ident = case ident of Right name | isInternalName name -> internalHyperlink name | otherwise -> externalNameHyperlink name @@ -274,7 +270,7 @@ hyperlink thisModule (srcs, srcs') ident = case ident of externalNameHyperlink name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name] + ! [Html.href $ hypSrcModuleNameUrl mdl name] Just (SrcExternal path) -> let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path in Html.anchor content ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs ===================================== @@ -9,7 +9,6 @@ module Haddock.Backends.Hyperlinker.Utils , hypSrcNameUrl , hypSrcLineUrl , hypSrcModuleNameUrl - , hypSrcModuleNameUrl' , hypSrcModuleLineUrl , hypSrcModuleUrlFormat , hypSrcModuleNameUrlFormat @@ -72,12 +71,6 @@ hypSrcLineUrl line = "line-" ++ show line hypSrcModuleNameUrl :: Module -> Name -> String hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name -{-# INLINE hypSrcModuleNameUrl' #-} -hypSrcModuleNameUrl' :: Module -> Module -> Name -> String -hypSrcModuleNameUrl' this_mdl mdl name - | this_mdl == mdl = "#" ++ hypSrcNameUrl name - | otherwise = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name - {-# INLINE hypSrcModuleLineUrl #-} hypSrcModuleLineUrl :: Module -> Int -> String hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line ===================================== utils/hpc ===================================== @@ -1 +1 @@ -Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5 +Subproject commit d1780eb21c1e5a1227fff80c8d325d5142f04255 ===================================== utils/hsc2hs ===================================== @@ -1 +1 @@ -Subproject commit fe3990b9f35000427b016a79330d9f195587cad8 +Subproject commit c3b21800a67366c9591dc85a471d1dfdb1efcf29 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b31a55f1c93b02f321a24883441adb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b31a55f1c93b02f321a24883441adb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/shorter-this-module-links] Use showUnique in internalAnchorIdent
by Oleg Grenrus (＠phadej) 14 Sep '25

14 Sep '25

Oleg Grenrus pushed to branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC Commits: 6d4eb0db by Oleg Grenrus at 2025-09-14T19:04:32+03:00 Use showUnique in internalAnchorIdent Showing the key of Unique as a number is generally not a great idea. GHC Unique has a tag in high bits, so the raw number is unnecessarily big. So now we have ```html <a href="#l-rvgK">bar</a> ``` instead of ```html <a href="#local-6989586621679015689">bar</a> ``` Together with previous changes of shorter intra-module links the effect on compressed files is not huge, that is expected as we simply remove repetitive contents which pack well. ``` 12_694_206 Agda-2.9.0-docs-orig.tar.gz 12_566_065 Agda-2.9.0-docs.tar.gz ``` However when unpacked, the difference can be significant, e.g. Agda's largest module source got 5% reduction: ``` 14_230_117 Agda.Syntax.Parser.Parser.html 13_422_109 Agda.Syntax.Parser.Parser.html ``` The whole hyperlinked source code directory got similar reduction ``` 121M Agda-2.9.0-docs-orig/src 114M Agda-2.9.0-docs/src ``` For the reference, sources are about 2/3 of the generated haddocks ``` 178M Agda-2.9.0-docs-old 172M Agda-2.9.0-docs ``` so we get around 3.5% size reduction overall. Not bad for a small local changes. - - - - - 3 changed files: - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs Changes: ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -80,7 +80,6 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do nc <- freshNameCache HieFile { hie_hs_file = file - , hie_module = thisModule , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc @@ -117,7 +116,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens' -- Produce and write out the hyperlinked sources - writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens + writeUtf8File path . renderToString pretty . render' fullAst $ tokens where dflags = ifaceDynFlags iface sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle @@ -129,7 +128,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do False -- lex Haddocks as comment tokens True -- produce comment tokens False -- produce position pragmas tokens - render' thisModule = render thisModule (Just srcCssFile) (Just highlightScript) srcs + render' = render (Just srcCssFile) (Just highlightScript) srcs path = srcdir </> hypSrcModuleFile (ifaceMod iface) emptyHieAst fileFs = ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -15,7 +15,7 @@ import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext) import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique) import GHC.Types.SrcLoc import GHC.Types.Unique (getKey) -import GHC.Unit.Module (Module, ModuleName, moduleNameString) +import GHC.Unit.Module (ModuleName, moduleNameString) import GHC.Utils.Encoding (utf8DecodeByteString) import System.FilePath.Posix ((</>)) import Text.XHtml (Html, HtmlAttr, (!)) @@ -28,9 +28,7 @@ type StyleClass = String -- | Produce the HTML corresponding to a hyperlinked Haskell source render - :: Module - -- ^ this module - -> Maybe FilePath + :: Maybe FilePath -- ^ path to the CSS file -> Maybe FilePath -- ^ path to the JS file @@ -41,12 +39,12 @@ render -> [Token] -- ^ tokens to render -> Html -render thisModule mcss mjs srcs ast tokens = header mcss mjs <> body thisModule srcs ast tokens +render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens -body :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html -body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc +body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html +body srcs ast tokens = Html.body . Html.pre $ hypsrc where - hypsrc = renderWithAst thisModule srcs ast tokens + hypsrc = renderWithAst srcs ast tokens header :: Maybe FilePath -> Maybe FilePath -> Html header Nothing Nothing = Html.noHtml @@ -77,9 +75,9 @@ splitTokens ast toks = (before, during, after) -- | Turn a list of tokens into hyperlinked sources, threading in relevant link -- information from the 'HieAST'. -renderWithAst :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html -renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of - [tok] | nodeSpan == tkSpan tok -> richToken thisModule srcs nodeInfo tok +renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html +renderWithAst srcs Node{..} toks = anchored $ case toks of + [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators -- as multiple tokens. -- @@ -94,7 +92,6 @@ renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken - thisModule srcs nodeInfo ( Token @@ -107,7 +104,6 @@ renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken - thisModule srcs nodeInfo ( Token @@ -122,7 +118,7 @@ renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of go _ [] = mempty go [] xs = foldMap renderToken xs go (cur : rest) xs = - foldMap renderToken before <> renderWithAst thisModule srcs cur during <> go rest after + foldMap renderToken before <> renderWithAst srcs cur during <> go rest after where (before, during, after) = splitTokens cur xs anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo) @@ -141,8 +137,8 @@ renderToken Token{..} tokenSpan = Html.thespan (Html.toHtml tkValue') -- | Given information about the source position of definitions, render a token -richToken :: Module -> SrcMaps -> NodeInfo PrintedType -> Token -> Html -richToken thisModule srcs details Token{..} +richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html +richToken srcs details Token{..} | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' | otherwise = annotate details $ linked content where @@ -159,7 +155,7 @@ richToken thisModule srcs details Token{..} -- If we have name information, we can make links linked = case identDet of - Just (n, _) -> hyperlink thisModule srcs n + Just (n, _) -> hyperlink srcs n Nothing -> id -- | Remove CRLFs from source @@ -257,8 +253,8 @@ internalAnchorIdent :: Name -> String internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique -- | Generate the HTML hyperlink for an identifier -hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html -hyperlink thisModule (srcs, srcs') ident = case ident of +hyperlink :: SrcMaps -> Identifier -> Html -> Html +hyperlink (srcs, srcs') ident = case ident of Right name | isInternalName name -> internalHyperlink name | otherwise -> externalNameHyperlink name @@ -274,7 +270,7 @@ hyperlink thisModule (srcs, srcs') ident = case ident of externalNameHyperlink name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name] + ! [Html.href $ hypSrcModuleNameUrl mdl name] Just (SrcExternal path) -> let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path in Html.anchor content ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs ===================================== @@ -9,7 +9,6 @@ module Haddock.Backends.Hyperlinker.Utils , hypSrcNameUrl , hypSrcLineUrl , hypSrcModuleNameUrl - , hypSrcModuleNameUrl' , hypSrcModuleLineUrl , hypSrcModuleUrlFormat , hypSrcModuleNameUrlFormat @@ -72,12 +71,6 @@ hypSrcLineUrl line = "line-" ++ show line hypSrcModuleNameUrl :: Module -> Name -> String hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name -{-# INLINE hypSrcModuleNameUrl' #-} -hypSrcModuleNameUrl' :: Module -> Module -> Name -> String -hypSrcModuleNameUrl' this_mdl mdl name - | this_mdl == mdl = "#" ++ hypSrcNameUrl name - | otherwise = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name - {-# INLINE hypSrcModuleLineUrl #-} hypSrcModuleLineUrl :: Module -> Int -> String hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d4eb0db7ecfc45da62c8e3d1b57963… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d4eb0db7ecfc45da62c8e3d1b57963… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/shorter-this-module-links] Use showUnique in internalAnchorIdent
by Oleg Grenrus (＠phadej) 14 Sep '25

14 Sep '25

Oleg Grenrus pushed to branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC Commits: 13f9d8c3 by Oleg Grenrus at 2025-09-14T19:02:49+03:00 Use showUnique in internalAnchorIdent Showing the key of Unique as a number is generally not a great idea. GHC Unique has a tag in high bits, so the raw number is unnecessarily big. So now we have ```html <a href="#l-rvgK">bar</a> ``` instead of ```html <a href="#local-6989586621679015689">bar</a> ``` Together with previous changes of shorter intra-module links the effect on compressed files is not huge, that is expected as we simply remove repetitive contents which pack well. ``` 12_694_206 Agda-2.9.0-docs-orig.tar.gz 12_566_065 Agda-2.9.0-docs.tar.gz ``` However when unpacked, the difference can be significant, e.g. Agda's largest module source got 5% reduction: ``` 14_230_117 Agda.Syntax.Parser.Parser.html 13_422_109 Agda.Syntax.Parser.Parser.html ``` The whole hyperlinked source code directory got similar reduction ``` 121M Agda-2.9.0-docs-orig/src 114M Agda-2.9.0-docs/src ``` For the reference, sources are about 2/3 of the generated haddocks ``` 178M Agda-2.9.0-docs-old 172M Agda-2.9.0-docs ``` so we get around 3.5% size reduction overall. Not bad for a small local changes. - - - - - 5 changed files: - libffi-tarballs - nofib - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/hpc - utils/hsc2hs Changes: ===================================== libffi-tarballs ===================================== @@ -1 +1 @@ -Subproject commit 7c51059557b68d29820a0a87cebfa6fe73c8adf5 +Subproject commit 89a9b01c5647c8f0d3899435b99df690f582e9f1 ===================================== nofib ===================================== @@ -1 +1 @@ -Subproject commit b7391df4540ac8b11b35e1b2e2c15819b5171798 +Subproject commit da7eed00e494aba1da9f51cb92089ca10e2454e7 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -14,7 +14,7 @@ import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext) import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique) import GHC.Types.SrcLoc -import GHC.Types.Unique (getKey) +import GHC.Types.Unique (showUnique) import GHC.Unit.Module (Module, ModuleName, moduleNameString) import GHC.Utils.Encoding (utf8DecodeByteString) import System.FilePath.Posix ((</>)) @@ -254,7 +254,7 @@ externalAnchorIdent :: Name -> String externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: Name -> String -internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique +internalAnchorIdent = ("l-" ++) . showUnique . nameUnique -- | Generate the HTML hyperlink for an identifier hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html ===================================== utils/hpc ===================================== @@ -1 +1 @@ -Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5 +Subproject commit d1780eb21c1e5a1227fff80c8d325d5142f04255 ===================================== utils/hsc2hs ===================================== @@ -1 +1 @@ -Subproject commit fe3990b9f35000427b016a79330d9f195587cad8 +Subproject commit c3b21800a67366c9591dc85a471d1dfdb1efcf29 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13f9d8c3ce03f14fc2d42374e76b84c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13f9d8c3ce03f14fc2d42374e76b84c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/shorter-this-module-links] 3 commits: Use isPrint in showUnique
by Oleg Grenrus (＠phadej) 14 Sep '25

14 Sep '25

Oleg Grenrus pushed to branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC Commits: 879ce9f0 by Oleg Grenrus at 2025-09-14T18:36:55+03:00 Use isPrint in showUnique The comment say ``` -- Avoid emitting non-printable characters in pretty uniques. See #25989. ``` so let the code do exactly that. There are tags (at least : and 0 .. 9) which weren't in A .. z range. - - - - - 3e6a242a by Oleg Grenrus at 2025-09-14T18:36:55+03:00 Shorten in-module links in hyperlinked source Instead of href="This.Module#ident" to just "#ident" - - - - - 4d5bccf8 by Oleg Grenrus at 2025-09-14T18:46:13+03:00 Use showUnique in internalAnchorIdent Showing the key of Unique as a number is generally not a great idea. GHC Unique has a tag in high bits, so the raw number is unnecessarily big. So now we have ```html <a href="#l-rvgK">bar</a> ``` instead of ```html <a href="#local-6989586621679015689">bar</a> ``` Together with previous changes of shorter intra-module links the effect on compressed files is not huge, that is expected as we simply remove repetitive contents which pack well. ``` 12_694_206 Agda-2.9.0-docs-orig.tar.gz 12_566_065 Agda-2.9.0-docs.tar.gz ``` However when unpacked, the difference can be significant, e.g. Agda's largest module source got 5% reduction: ``` 14_230_117 Agda.Syntax.Parser.Parser.html 13_422_109 Agda.Syntax.Parser.Parser.html ``` The whole hyperlinked source code directory got similar reduction ``` 121M Agda-2.9.0-docs-orig/src 114M Agda-2.9.0-docs/src ``` For the reference, sources are about 2/3 of the generated haddocks ``` 178M Agda-2.9.0-docs-old 172M Agda-2.9.0-docs ``` so we get around 3.5% size reduction overall. Not bad for a small local changes. - - - - - 27 changed files: - compiler/GHC/Types/Unique.hs - libffi-tarballs - libraries/Cabal - libraries/Win32 - libraries/array - libraries/containers - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/filepath - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/terminfo - libraries/text - libraries/time - libraries/unix - nofib - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs - utils/hpc - utils/hsc2hs Changes: ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -28,6 +28,7 @@ module GHC.Types.Unique ( -- ** Constructors, destructors and operations on 'Unique's hasKey, + showUnique, pprUniqueAlways, mkTag, @@ -61,7 +62,7 @@ import GHC.Utils.Word64 (intToWord64, word64ToInt) import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) import GHC.Word ( Word64 ) -import Data.Char ( chr, ord ) +import Data.Char ( chr, ord, isPrint ) import Language.Haskell.Syntax.Module.Name @@ -308,8 +309,8 @@ showUnique uniq -- Avoid emitting non-printable characters in pretty uniques. -- See #25989. tagStr - | tag < 'A' || tag > 'z' = show (ord tag) ++ "_" - | otherwise = [tag] + | not (isPrint tag) = show (ord tag) ++ "_" + | otherwise = [tag] pprUniqueAlways :: IsLine doc => Unique -> doc -- The "always" means regardless of -dsuppress-uniques ===================================== libffi-tarballs ===================================== @@ -1 +1 @@ -Subproject commit 7c51059557b68d29820a0a87cebfa6fe73c8adf5 +Subproject commit 89a9b01c5647c8f0d3899435b99df690f582e9f1 ===================================== libraries/Cabal ===================================== @@ -1 +1 @@ -Subproject commit d9b0904b49dc84e0bfc79062daf2bbdf9d22a422 +Subproject commit 269fd808e5d80223a229b6b19edfe6f5b109007a ===================================== libraries/Win32 ===================================== @@ -1 +1 @@ -Subproject commit 7d0772bb265a6c59eb14c441cf65c778895528df +Subproject commit 027cbcf0de25d681823ea92fb545a2604c3a6a8b ===================================== libraries/array ===================================== @@ -1 +1 @@ -Subproject commit 6d59d5deb4f2a12656ab4c4371c0d12dac4875ef +Subproject commit e7ffb82fd40134da21d7642a41568f32c77c1a04 ===================================== libraries/containers ===================================== @@ -1 +1 @@ -Subproject commit 801b06e5d4392b028e519d5ca116a2881d559721 +Subproject commit 4fda06c43ea14f808748aa8988158946c3ce0caf ===================================== libraries/deepseq ===================================== @@ -1 +1 @@ -Subproject commit ae2762ac241a61852c9ff4c287af234fb1ad931f +Subproject commit af115cc226cc87fba89d0f6e2e9212e755c24983 ===================================== libraries/directory ===================================== @@ -1 +1 @@ -Subproject commit 6442a3cf04f74d82cdf8c9213324313d52b23d28 +Subproject commit 005fa061171a55d35ce8dfe936cf3703525a8616 ===================================== libraries/exceptions ===================================== @@ -1 +1 @@ -Subproject commit b6c4290124eb1138358bf04ad9f33e67f6c5c1d8 +Subproject commit 8e55b720f45db91f4895f710863ef9dbc10fe569 ===================================== libraries/filepath ===================================== @@ -1 +1 @@ -Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe +Subproject commit 65b0f8f31aac4a306135e27734988327f8eb1e6f ===================================== libraries/haskeline ===================================== @@ -1 +1 @@ -Subproject commit 991953cd5d3bb9e8057de4a0d8f2cae3455865d8 +Subproject commit 5f4bf62bf1f4846ad0b8d1fa9d45f902e3934511 ===================================== libraries/hpc ===================================== @@ -1 +1 @@ -Subproject commit 12675279dc5cbea4ade8b5157b080390d598f03f +Subproject commit f321056015dc36b454f323ca4285d684f4f782d3 ===================================== libraries/os-string ===================================== @@ -1 +1 @@ -Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1 +Subproject commit 4b5efedcd2da9314edda80d973a44e67020370db ===================================== libraries/parsec ===================================== @@ -1 +1 @@ -Subproject commit 552730e23e1fd2dae46a60d75138b8d173492462 +Subproject commit b87122c1c74b8240e65044a8f600f0427d4dd9c3 ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit ae50731b5fb221a7631f7e9d818fc6716c85c51e +Subproject commit 9c3bfc214c72bbd0c8a30a1c41465deed0feaf47 ===================================== libraries/semaphore-compat ===================================== @@ -1 +1 @@ -Subproject commit ba87d1bb0209bd9f29bda1c878ddf345f8a2b199 +Subproject commit 54882cd9a07322a4cf95d4fc0627107eaf1eb051 ===================================== libraries/stm ===================================== @@ -1 +1 @@ -Subproject commit 23bdcc2319965911af28542e76fc01f37c107d40 +Subproject commit def18948f42a2eb8c34efdf65f7e614d1f6d5703 ===================================== libraries/terminfo ===================================== @@ -1 +1 @@ -Subproject commit 16db154e3e97e6bff62329574163851a7090f3b6 +Subproject commit 788ce671cb1cec54c3c9b3ac1c1ba189e8424819 ===================================== libraries/text ===================================== @@ -1 +1 @@ -Subproject commit 5f343f668f421bfb30cead594e52d0ac6206ff67 +Subproject commit b86564cae8d7262c7c4e7afe7a9163c83de3f175 ===================================== libraries/time ===================================== @@ -1 +1 @@ -Subproject commit 507f50844802f1469ba6cadfeefd4e3fecee0416 +Subproject commit e5c5d1987011efe88a21ab6ded45aaa33a16274f ===================================== libraries/unix ===================================== @@ -1 +1 @@ -Subproject commit c9b3e95b5c15b118e55522bd92963038c6a88160 +Subproject commit 74ae1c0d9dd1518434f7d6cd3e63d7769599e0f9 ===================================== nofib ===================================== @@ -1 +1 @@ -Subproject commit b7391df4540ac8b11b35e1b2e2c15819b5171798 +Subproject commit da7eed00e494aba1da9f51cb92089ca10e2454e7 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -80,6 +80,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do nc <- freshNameCache HieFile { hie_hs_file = file + , hie_module = thisModule , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc @@ -116,7 +117,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens' -- Produce and write out the hyperlinked sources - writeUtf8File path . renderToString pretty . render' fullAst $ tokens + writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens where dflags = ifaceDynFlags iface sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle @@ -128,7 +129,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do False -- lex Haddocks as comment tokens True -- produce comment tokens False -- produce position pragmas tokens - render' = render (Just srcCssFile) (Just highlightScript) srcs + render' thisModule = render thisModule (Just srcCssFile) (Just highlightScript) srcs path = srcdir </> hypSrcModuleFile (ifaceMod iface) emptyHieAst fileFs = ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -14,8 +14,8 @@ import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext) import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique) import GHC.Types.SrcLoc -import GHC.Types.Unique (getKey) -import GHC.Unit.Module (ModuleName, moduleNameString) +import GHC.Types.Unique (showUnique) +import GHC.Unit.Module (Module, ModuleName, moduleNameString) import GHC.Utils.Encoding (utf8DecodeByteString) import System.FilePath.Posix ((</>)) import Text.XHtml (Html, HtmlAttr, (!)) @@ -28,7 +28,9 @@ type StyleClass = String -- | Produce the HTML corresponding to a hyperlinked Haskell source render - :: Maybe FilePath + :: Module + -- ^ this module + -> Maybe FilePath -- ^ path to the CSS file -> Maybe FilePath -- ^ path to the JS file @@ -39,12 +41,12 @@ render -> [Token] -- ^ tokens to render -> Html -render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens +render thisModule mcss mjs srcs ast tokens = header mcss mjs <> body thisModule srcs ast tokens -body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html -body srcs ast tokens = Html.body . Html.pre $ hypsrc +body :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html +body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc where - hypsrc = renderWithAst srcs ast tokens + hypsrc = renderWithAst thisModule srcs ast tokens header :: Maybe FilePath -> Maybe FilePath -> Html header Nothing Nothing = Html.noHtml @@ -75,9 +77,9 @@ splitTokens ast toks = (before, during, after) -- | Turn a list of tokens into hyperlinked sources, threading in relevant link -- information from the 'HieAST'. -renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html -renderWithAst srcs Node{..} toks = anchored $ case toks of - [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok +renderWithAst :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html +renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of + [tok] | nodeSpan == tkSpan tok -> richToken thisModule srcs nodeInfo tok -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators -- as multiple tokens. -- @@ -92,6 +94,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken + thisModule srcs nodeInfo ( Token @@ -104,6 +107,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken + thisModule srcs nodeInfo ( Token @@ -118,7 +122,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of go _ [] = mempty go [] xs = foldMap renderToken xs go (cur : rest) xs = - foldMap renderToken before <> renderWithAst srcs cur during <> go rest after + foldMap renderToken before <> renderWithAst thisModule srcs cur during <> go rest after where (before, during, after) = splitTokens cur xs anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo) @@ -137,8 +141,8 @@ renderToken Token{..} tokenSpan = Html.thespan (Html.toHtml tkValue') -- | Given information about the source position of definitions, render a token -richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html -richToken srcs details Token{..} +richToken :: Module -> SrcMaps -> NodeInfo PrintedType -> Token -> Html +richToken thisModule srcs details Token{..} | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' | otherwise = annotate details $ linked content where @@ -155,7 +159,7 @@ richToken srcs details Token{..} -- If we have name information, we can make links linked = case identDet of - Just (n, _) -> hyperlink srcs n + Just (n, _) -> hyperlink thisModule srcs n Nothing -> id -- | Remove CRLFs from source @@ -250,11 +254,11 @@ externalAnchorIdent :: Name -> String externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: Name -> String -internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique +internalAnchorIdent = ("l-" ++) . showUnique . nameUnique -- | Generate the HTML hyperlink for an identifier -hyperlink :: SrcMaps -> Identifier -> Html -> Html -hyperlink (srcs, srcs') ident = case ident of +hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html +hyperlink thisModule (srcs, srcs') ident = case ident of Right name | isInternalName name -> internalHyperlink name | otherwise -> externalNameHyperlink name @@ -270,7 +274,7 @@ hyperlink (srcs, srcs') ident = case ident of externalNameHyperlink name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleNameUrl mdl name] + ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name] Just (SrcExternal path) -> let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path in Html.anchor content ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs ===================================== @@ -9,6 +9,7 @@ module Haddock.Backends.Hyperlinker.Utils , hypSrcNameUrl , hypSrcLineUrl , hypSrcModuleNameUrl + , hypSrcModuleNameUrl' , hypSrcModuleLineUrl , hypSrcModuleUrlFormat , hypSrcModuleNameUrlFormat @@ -71,6 +72,12 @@ hypSrcLineUrl line = "line-" ++ show line hypSrcModuleNameUrl :: Module -> Name -> String hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name +{-# INLINE hypSrcModuleNameUrl' #-} +hypSrcModuleNameUrl' :: Module -> Module -> Name -> String +hypSrcModuleNameUrl' this_mdl mdl name + | this_mdl == mdl = "#" ++ hypSrcNameUrl name + | otherwise = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name + {-# INLINE hypSrcModuleLineUrl #-} hypSrcModuleLineUrl :: Module -> Int -> String hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line ===================================== utils/hpc ===================================== @@ -1 +1 @@ -Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5 +Subproject commit d1780eb21c1e5a1227fff80c8d325d5142f04255 ===================================== utils/hsc2hs ===================================== @@ -1 +1 @@ -Subproject commit fe3990b9f35000427b016a79330d9f195587cad8 +Subproject commit c3b21800a67366c9591dc85a471d1dfdb1efcf29 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/356e9341100a737d463bcf6a9ad318… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/356e9341100a737d463bcf6a9ad318… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/shorter-this-module-links] WIP
by Oleg Grenrus (＠phadej) 14 Sep '25

14 Sep '25

Oleg Grenrus pushed to branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC Commits: 356e9341 by Oleg Grenrus at 2025-09-14T15:15:18+03:00 WIP - - - - - 3 changed files: - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs Changes: ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -80,6 +80,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do nc <- freshNameCache HieFile { hie_hs_file = file + , hie_module = thisModule , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc @@ -116,7 +117,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens' -- Produce and write out the hyperlinked sources - writeUtf8File path . renderToString pretty . render' fullAst $ tokens + writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens where dflags = ifaceDynFlags iface sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle @@ -128,7 +129,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do False -- lex Haddocks as comment tokens True -- produce comment tokens False -- produce position pragmas tokens - render' = render (Just srcCssFile) (Just highlightScript) srcs + render' thisModule = render thisModule (Just srcCssFile) (Just highlightScript) srcs path = srcdir </> hypSrcModuleFile (ifaceMod iface) emptyHieAst fileFs = ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs ===================================== @@ -15,7 +15,7 @@ import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext) import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique) import GHC.Types.SrcLoc import GHC.Types.Unique (getKey) -import GHC.Unit.Module (ModuleName, moduleNameString) +import GHC.Unit.Module (Module, ModuleName, moduleNameString) import GHC.Utils.Encoding (utf8DecodeByteString) import System.FilePath.Posix ((</>)) import Text.XHtml (Html, HtmlAttr, (!)) @@ -28,7 +28,9 @@ type StyleClass = String -- | Produce the HTML corresponding to a hyperlinked Haskell source render - :: Maybe FilePath + :: Module + -- ^ this module + -> Maybe FilePath -- ^ path to the CSS file -> Maybe FilePath -- ^ path to the JS file @@ -39,12 +41,12 @@ render -> [Token] -- ^ tokens to render -> Html -render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens +render thisModule mcss mjs srcs ast tokens = header mcss mjs <> body thisModule srcs ast tokens -body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html -body srcs ast tokens = Html.body . Html.pre $ hypsrc +body :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html +body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc where - hypsrc = renderWithAst srcs ast tokens + hypsrc = renderWithAst thisModule srcs ast tokens header :: Maybe FilePath -> Maybe FilePath -> Html header Nothing Nothing = Html.noHtml @@ -75,9 +77,9 @@ splitTokens ast toks = (before, during, after) -- | Turn a list of tokens into hyperlinked sources, threading in relevant link -- information from the 'HieAST'. -renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html -renderWithAst srcs Node{..} toks = anchored $ case toks of - [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok +renderWithAst :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html +renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of + [tok] | nodeSpan == tkSpan tok -> richToken thisModule srcs nodeInfo tok -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators -- as multiple tokens. -- @@ -92,6 +94,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken + thisModule srcs nodeInfo ( Token @@ -104,6 +107,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken + thisModule srcs nodeInfo ( Token @@ -118,7 +122,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of go _ [] = mempty go [] xs = foldMap renderToken xs go (cur : rest) xs = - foldMap renderToken before <> renderWithAst srcs cur during <> go rest after + foldMap renderToken before <> renderWithAst thisModule srcs cur during <> go rest after where (before, during, after) = splitTokens cur xs anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo) @@ -137,8 +141,8 @@ renderToken Token{..} tokenSpan = Html.thespan (Html.toHtml tkValue') -- | Given information about the source position of definitions, render a token -richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html -richToken srcs details Token{..} +richToken :: Module -> SrcMaps -> NodeInfo PrintedType -> Token -> Html +richToken thisModule srcs details Token{..} | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' | otherwise = annotate details $ linked content where @@ -155,7 +159,7 @@ richToken srcs details Token{..} -- If we have name information, we can make links linked = case identDet of - Just (n, _) -> hyperlink srcs n + Just (n, _) -> hyperlink thisModule srcs n Nothing -> id -- | Remove CRLFs from source @@ -253,8 +257,8 @@ internalAnchorIdent :: Name -> String internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique -- | Generate the HTML hyperlink for an identifier -hyperlink :: SrcMaps -> Identifier -> Html -> Html -hyperlink (srcs, srcs') ident = case ident of +hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html +hyperlink thisModule (srcs, srcs') ident = case ident of Right name | isInternalName name -> internalHyperlink name | otherwise -> externalNameHyperlink name @@ -270,7 +274,7 @@ hyperlink (srcs, srcs') ident = case ident of externalNameHyperlink name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content - ! [Html.href $ hypSrcModuleNameUrl mdl name] + ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name] Just (SrcExternal path) -> let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path in Html.anchor content ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs ===================================== @@ -9,6 +9,7 @@ module Haddock.Backends.Hyperlinker.Utils , hypSrcNameUrl , hypSrcLineUrl , hypSrcModuleNameUrl + , hypSrcModuleNameUrl' , hypSrcModuleLineUrl , hypSrcModuleUrlFormat , hypSrcModuleNameUrlFormat @@ -71,6 +72,12 @@ hypSrcLineUrl line = "line-" ++ show line hypSrcModuleNameUrl :: Module -> Name -> String hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name +{-# INLINE hypSrcModuleNameUrl' #-} +hypSrcModuleNameUrl' :: Module -> Module -> Name -> String +hypSrcModuleNameUrl' this_mdl mdl name + | this_mdl == mdl = "#" ++ hypSrcNameUrl name + | otherwise = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name + {-# INLINE hypSrcModuleLineUrl #-} hypSrcModuleLineUrl :: Module -> Int -> String hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/356e9341100a737d463bcf6a9ad3188… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/356e9341100a737d463bcf6a9ad3188… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/shorter-this-module-links
by Oleg Grenrus (＠phadej) 14 Sep '25

14 Sep '25

Oleg Grenrus pushed new branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/shorter-this-module-links You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghci-no-simpl] 2 commits: compiler: use modified dflags/session with -O0 in hscCompileCoreExpr
by Cheng Shao (＠TerrorJack) 14 Sep '25

14 Sep '25

Cheng Shao pushed to branch wip/ghci-no-simpl at Glasgow Haskell Compiler / GHC Commits: 63bb86db by Cheng Shao at 2025-09-14T12:53:55+02:00 compiler: use modified dflags/session with -O0 in hscCompileCoreExpr This commit makes the compiler use modified dflags/session with -O0 in hscCompileCoreExpr to do less work in not just the Core simplification step, but also later steps like CorePrep. - - - - - 81f0e496 by Cheng Shao at 2025-09-14T12:54:14+02:00 compiler: remove unused simplifyExpr logic This commit removes the now unused simplifyExpr logic in the tree. - - - - - 4 changed files: - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Driver/Config/Core/Opt/Simplify.hs - compiler/GHC/Driver/Main.hs Changes: ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -6,7 +6,7 @@ {-# LANGUAGE CPP #-} -module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where +module GHC.Core.Opt.Pipeline ( core2core ) where import GHC.Prelude @@ -27,7 +27,7 @@ import GHC.Core.Ppr ( pprCoreBindings ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) import GHC.Core.Lint ( lintAnnots ) import GHC.Core.Lint.Interactive ( interactiveInScope ) -import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm ) +import GHC.Core.Opt.Simplify ( simplifyPgm ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad import GHC.Core.Opt.Pipeline.Types ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} module GHC.Core.Opt.Simplify - ( SimplifyExprOpts(..), SimplifyOpts(..) - , simplifyExpr, simplifyPgm + ( SimplifyOpts(..) + , simplifyPgm ) where import GHC.Prelude @@ -11,20 +11,18 @@ import GHC.Driver.Flags import GHC.Core import GHC.Core.Rules -import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) -import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) -import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) +import GHC.Core.Ppr ( pprCoreBindings ) +import GHC.Core.Opt.OccurAnal ( occurAnalysePgm ) +import GHC.Core.Stats ( coreBindsSize, coreBindsStats ) import GHC.Core.Utils ( mkTicks, stripTicksTop ) import GHC.Core.Lint ( LintPassResultConfig, dumpPassResult, lintPassResult ) -import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) +import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplImpRules ) import GHC.Core.Opt.Simplify.Utils ( activeRule ) import GHC.Core.Opt.Simplify.Inline ( activeUnfolding ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Stats ( simplCountN ) -import GHC.Core.FamInstEnv -import GHC.Utils.Error ( withTiming ) import GHC.Utils.Logger as Logger import GHC.Utils.Outputable import GHC.Utils.Constants (debugIsOn) @@ -44,72 +42,6 @@ import GHC.Types.Unique.FM import Control.Monad import Data.Foldable ( for_ ) -{- -************************************************************************ -* * - Gentle simplification -* * -************************************************************************ --} - --- | Configuration record for `simplifyExpr`. --- The values of this datatype are /only/ driven by the demands of that function. -data SimplifyExprOpts = SimplifyExprOpts - { se_fam_inst :: ![FamInst] - , se_mode :: !SimplMode - , se_top_env_cfg :: !TopEnvConfig - } - -simplifyExpr :: Logger - -> ExternalUnitCache - -> SimplifyExprOpts - -> CoreExpr - -> IO CoreExpr --- ^ Simplify an expression using 'simplExprGently'. --- --- See 'simplExprGently' for details. -simplifyExpr logger euc opts expr - = withTiming logger (text "Simplify [expr]") (const ()) $ - do { eps <- eucEPS euc ; - ; let fam_envs = ( eps_fam_inst_env eps - , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts - ) - simpl_env = mkSimplEnv (se_mode opts) fam_envs - top_env_cfg = se_top_env_cfg opts - read_eps_rules = eps_rule_base <$> eucEPS euc - read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules - - ; let sz = exprSize expr - - ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $ - simplExprGently simpl_env expr - - ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats - "Simplifier statistics" FormatText (pprSimplCount counts) - - ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" - FormatCore - (pprCoreExpr expr') - - ; return expr' - } - -simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr --- ^ Simplifies an expression by doing occurrence analysis, then simplification, --- and repeating (twice currently), because one pass alone leaves tons of crud. --- --- Used only: --- --- 1. for user expressions typed in at the interactive prompt (see 'GHC.Driver.Main.hscStmt'), --- 2. for Template Haskell splices (see 'GHC.Tc.Gen.Splice.runMeta'). --- --- The name 'Gently' suggests that the SimplMode is InitialPhase, --- and in fact that is so.... but the 'Gently' in 'simplExprGently' doesn't --- enforce that; it just simplifies the expression twice. -simplExprGently env expr = do - expr1 <- simplExpr env (occurAnalyseExpr expr) - simplExpr env (occurAnalyseExpr expr1) - {- ************************************************************************ * * ===================================== compiler/GHC/Driver/Config/Core/Opt/Simplify.hs ===================================== @@ -1,6 +1,5 @@ module GHC.Driver.Config.Core.Opt.Simplify - ( initSimplifyExprOpts - , initSimplifyOpts + ( initSimplifyOpts , initSimplMode , initGentleSimplMode ) where @@ -9,7 +8,7 @@ import GHC.Prelude import GHC.Core.Rules ( RuleBase ) import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) -import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) ) +import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..), SimplPhase(..) ) import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) ) @@ -19,26 +18,9 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts ) import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), gopt ) -import GHC.Runtime.Context ( InteractiveContext(..) ) - import GHC.Types.Basic ( CompilerPhase(..) ) import GHC.Types.Var ( Var ) -initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts -initSimplifyExprOpts dflags ic = SimplifyExprOpts - { se_fam_inst = snd $ ic_instances ic - , se_mode = (initSimplMode dflags InitialPhase "GHCi") - { sm_inline = False - -- Do not do any inlining, in case we expose some - -- unboxed tuple stuff that confuses the bytecode - -- interpreter - } - , se_top_env_cfg = TopEnvConfig - { te_history_size = historySize dflags - , te_tick_factor = simplTickFactor dflags - } - } - initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let -- This is a particularly ugly construction, but we will get rid of it in !8341. ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -2709,28 +2709,35 @@ hscCompileCoreExpr hsc_env loc expr = Just h -> h hsc_env loc expr hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) -hscCompileCoreExpr' hsc_env srcspan ds_expr = do - {- Simplify it -} - let dflags = hsc_dflags hsc_env +hscCompileCoreExpr' hsc_env' srcspan ds_expr = do + -- Use modified `dflags` and session that sets -O0 and do less work + -- throughout the Core -> ByteCode pipeline under + -- `-funoptimized-core-for-interpreter`, even if current session + -- enables `-O1` or above. + let dflags' = hsc_dflags hsc_env' + unopt = gopt Opt_UnoptimizedCoreForInterpreter dflags' + dflags + | unopt = updOptLevel 0 dflags' + | otherwise = dflags' + hsc_env + | unopt = hsc_env' {hsc_dflags = dflags} + | otherwise = hsc_env' let logger = hsc_logger hsc_env + {- Simplify it -} let simpl_expr - -- Do less work under `-funoptimized-core-for-interpreter`, - -- use modified `dflags` that sets `-O0` here even if current - -- session enables `-O1` or above. - -- -- When generating bytecode for ghci via `hscParsedStmt`, we -- still need to enable inlining! For `let foo = Foo ...`, the -- ghci debugger expects `:print foo` to show `foo = <Foo> ...` -- without forcing `foo` first, without inlining `foo` -- would remain a top-level thunk instead of a datacon -- closure. We can skip inlining for TH splices though. - | gopt Opt_UnoptimizedCoreForInterpreter dflags = + | unopt = ( if srcspan == interactiveSrcSpan then simpleOptExpr else simpleOptExprNoInline ) - (initSimpleOpts $ updOptLevel 0 dflags) + (initSimpleOpts dflags) ds_expr | otherwise = simpleOptExpr (initSimpleOpts dflags) ds_expr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c307ec77223a2336196961e375ee75… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c307ec77223a2336196961e375ee75… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghci-no-simpl] 2 commits: compiler: use modified dflags/session with -O0 in hscCompileCoreExpr
by Cheng Shao (＠TerrorJack) 14 Sep '25

14 Sep '25

Cheng Shao pushed to branch wip/ghci-no-simpl at Glasgow Haskell Compiler / GHC Commits: 5d35dc97 by Cheng Shao at 2025-09-14T12:35:55+02:00 compiler: use modified dflags/session with -O0 in hscCompileCoreExpr This commit makes the compiler use modified dflags/session with -O0 in hscCompileCoreExpr to do less work in not just the Core simplification step, but also later steps, especially the STG -> STG pipeline. - - - - - c307ec77 by Cheng Shao at 2025-09-14T12:35:55+02:00 compiler: remove unused simplifyExpr logic This commit removes the now unused simplifyExpr logic in the tree. - - - - - 4 changed files: - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Driver/Config/Core/Opt/Simplify.hs - compiler/GHC/Driver/Main.hs Changes: ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -6,7 +6,7 @@ {-# LANGUAGE CPP #-} -module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where +module GHC.Core.Opt.Pipeline ( core2core ) where import GHC.Prelude @@ -27,7 +27,7 @@ import GHC.Core.Ppr ( pprCoreBindings ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) import GHC.Core.Lint ( lintAnnots ) import GHC.Core.Lint.Interactive ( interactiveInScope ) -import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm ) +import GHC.Core.Opt.Simplify ( simplifyPgm ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad import GHC.Core.Opt.Pipeline.Types ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} module GHC.Core.Opt.Simplify - ( SimplifyExprOpts(..), SimplifyOpts(..) - , simplifyExpr, simplifyPgm + ( SimplifyOpts(..) + , simplifyPgm ) where import GHC.Prelude @@ -11,20 +11,18 @@ import GHC.Driver.Flags import GHC.Core import GHC.Core.Rules -import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) -import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) -import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) +import GHC.Core.Ppr ( pprCoreBindings ) +import GHC.Core.Opt.OccurAnal ( occurAnalysePgm ) +import GHC.Core.Stats ( coreBindsSize, coreBindsStats ) import GHC.Core.Utils ( mkTicks, stripTicksTop ) import GHC.Core.Lint ( LintPassResultConfig, dumpPassResult, lintPassResult ) -import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) +import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplImpRules ) import GHC.Core.Opt.Simplify.Utils ( activeRule ) import GHC.Core.Opt.Simplify.Inline ( activeUnfolding ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Stats ( simplCountN ) -import GHC.Core.FamInstEnv -import GHC.Utils.Error ( withTiming ) import GHC.Utils.Logger as Logger import GHC.Utils.Outputable import GHC.Utils.Constants (debugIsOn) @@ -44,72 +42,6 @@ import GHC.Types.Unique.FM import Control.Monad import Data.Foldable ( for_ ) -{- -************************************************************************ -* * - Gentle simplification -* * -************************************************************************ --} - --- | Configuration record for `simplifyExpr`. --- The values of this datatype are /only/ driven by the demands of that function. -data SimplifyExprOpts = SimplifyExprOpts - { se_fam_inst :: ![FamInst] - , se_mode :: !SimplMode - , se_top_env_cfg :: !TopEnvConfig - } - -simplifyExpr :: Logger - -> ExternalUnitCache - -> SimplifyExprOpts - -> CoreExpr - -> IO CoreExpr --- ^ Simplify an expression using 'simplExprGently'. --- --- See 'simplExprGently' for details. -simplifyExpr logger euc opts expr - = withTiming logger (text "Simplify [expr]") (const ()) $ - do { eps <- eucEPS euc ; - ; let fam_envs = ( eps_fam_inst_env eps - , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts - ) - simpl_env = mkSimplEnv (se_mode opts) fam_envs - top_env_cfg = se_top_env_cfg opts - read_eps_rules = eps_rule_base <$> eucEPS euc - read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules - - ; let sz = exprSize expr - - ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $ - simplExprGently simpl_env expr - - ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats - "Simplifier statistics" FormatText (pprSimplCount counts) - - ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" - FormatCore - (pprCoreExpr expr') - - ; return expr' - } - -simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr --- ^ Simplifies an expression by doing occurrence analysis, then simplification, --- and repeating (twice currently), because one pass alone leaves tons of crud. --- --- Used only: --- --- 1. for user expressions typed in at the interactive prompt (see 'GHC.Driver.Main.hscStmt'), --- 2. for Template Haskell splices (see 'GHC.Tc.Gen.Splice.runMeta'). --- --- The name 'Gently' suggests that the SimplMode is InitialPhase, --- and in fact that is so.... but the 'Gently' in 'simplExprGently' doesn't --- enforce that; it just simplifies the expression twice. -simplExprGently env expr = do - expr1 <- simplExpr env (occurAnalyseExpr expr) - simplExpr env (occurAnalyseExpr expr1) - {- ************************************************************************ * * ===================================== compiler/GHC/Driver/Config/Core/Opt/Simplify.hs ===================================== @@ -1,6 +1,5 @@ module GHC.Driver.Config.Core.Opt.Simplify - ( initSimplifyExprOpts - , initSimplifyOpts + ( initSimplifyOpts , initSimplMode , initGentleSimplMode ) where @@ -9,7 +8,7 @@ import GHC.Prelude import GHC.Core.Rules ( RuleBase ) import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) -import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) ) +import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..), SimplPhase(..) ) import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) ) @@ -19,26 +18,9 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts ) import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), gopt ) -import GHC.Runtime.Context ( InteractiveContext(..) ) - import GHC.Types.Basic ( CompilerPhase(..) ) import GHC.Types.Var ( Var ) -initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts -initSimplifyExprOpts dflags ic = SimplifyExprOpts - { se_fam_inst = snd $ ic_instances ic - , se_mode = (initSimplMode dflags InitialPhase "GHCi") - { sm_inline = False - -- Do not do any inlining, in case we expose some - -- unboxed tuple stuff that confuses the bytecode - -- interpreter - } - , se_top_env_cfg = TopEnvConfig - { te_history_size = historySize dflags - , te_tick_factor = simplTickFactor dflags - } - } - initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let -- This is a particularly ugly construction, but we will get rid of it in !8341. ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -2709,28 +2709,35 @@ hscCompileCoreExpr hsc_env loc expr = Just h -> h hsc_env loc expr hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) -hscCompileCoreExpr' hsc_env srcspan ds_expr = do - {- Simplify it -} - let dflags = hsc_dflags hsc_env +hscCompileCoreExpr' hsc_env' srcspan ds_expr = do + -- Use modified `dflags` and session that sets -O0 and do less work + -- throughout the Core -> ByteCode pipeline under + -- `-funoptimized-core-for-interpreter`, even if current session + -- enables `-O1` or above. + let dflags' = hsc_dflags hsc_env' + unopt = gopt Opt_UnoptimizedCoreForInterpreter dflags' + dflags + | unopt = updOptLevel 0 dflags' + | otherwise = dflags' + hsc_env + | unopt = hsc_env' {hsc_dflags = dflags} + | otherwise = hsc_env' let logger = hsc_logger hsc_env + {- Simplify it -} let simpl_expr - -- Do less work under `-funoptimized-core-for-interpreter`, - -- use modified `dflags` that sets `-O0` here even if current - -- session enables `-O1` or above. - -- -- When generating bytecode for ghci via `hscParsedStmt`, we -- still need to enable inlining! For `let foo = Foo ...`, the -- ghci debugger expects `:print foo` to show `foo = <Foo> ...` -- without forcing `foo` first, without inlining `foo` -- would remain a top-level thunk instead of a datacon -- closure. We can skip inlining for TH splices though. - | gopt Opt_UnoptimizedCoreForInterpreter dflags = + | unopt = ( if srcspan == interactiveSrcSpan then simpleOptExpr else simpleOptExprNoInline ) - (initSimpleOpts $ updOptLevel 0 dflags) + (initSimpleOpts dflags) ds_expr | otherwise = simpleOptExpr (initSimpleOpts dflags) ds_expr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbc6f309570160457258b7de3a286a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbc6f309570160457258b7de3a286a… You're receiving this email because of your account on gitlab.haskell.org.

1 0