- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/az/ghc-cpp] 112 commits: Simplifier: Constant fold invald tagToEnum# calls to bottom expr.
by Alan Zimmerman (＠alanz) 23 Apr '25

23 Apr '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 2e204269 by Andreas Klebinger at 2025-04-22T12:20:41+02:00 Simplifier: Constant fold invald tagToEnum# calls to bottom expr. When applying tagToEnum# to a out-of-range value it's best to simply constant fold it to a bottom expression. That potentially allows more dead code elimination and makes debugging easier. Fixes #25976 - - - - - 7250fc0c by Matthew Pickering at 2025-04-22T16:24:04-04:00 Move -fno-code note into Downsweep module This note was left behind when all the code which referred to it was moved into the GHC.Driver.Downsweep module - - - - - d2dc89b4 by Matthew Pickering at 2025-04-22T16:24:04-04:00 Apply editing notes to Note [-fno-code mode] suggested by sheaf These notes were suggested in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14241 - - - - - f760da42 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 GHC-CPP: first rough proof of concept Processes #define FOO #ifdef FOO x = 1 #endif Into [ITcppIgnored [L loc ITcppDefine] ,ITcppIgnored [L loc ITcppIfdef] ,ITvarid "x" ,ITequal ,ITinteger (IL {il_text = SourceText "1", il_neg = False, il_value = 1}) ,ITcppIgnored [L loc ITcppEndif] ,ITeof] In time, ITcppIgnored will be pushed into a comment - - - - - ba8eca9c by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Tidy up before re-visiting the continuation mechanic - - - - - 37f29de9 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Switch preprocessor to continuation passing style Proof of concept, needs tidying up - - - - - 26a44e45 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Small cleanup - - - - - 957e9fbc by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Get rid of some cruft - - - - - fd702662 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Starting to integrate. Need to get the pragma recognised and set - - - - - 725f77c9 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Make cppTokens extend to end of line, and process CPP comments - - - - - 196b44dc by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Remove unused ITcppDefined - - - - - a76e00af by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Allow spaces between # and keyword for preprocessor directive - - - - - f328c99b by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Process CPP continuation lines They are emited as separate ITcppContinue tokens. Perhaps the processing should be more like a comment, and keep on going to the end. BUT, the last line needs to be slurped as a whole. - - - - - 337b85ae by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Accumulate CPP continuations, process when ready Can be simplified further, we only need one CPP token - - - - - 39bb5972 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Simplify Lexer interface. Only ITcpp We transfer directive lines through it, then parse them from scratch in the preprocessor. - - - - - d793afa9 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Deal with directive on last line, with no trailing \n - - - - - 73aa548c by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Start parsing and processing the directives - - - - - 43fd6c16 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Prepare for processing include files - - - - - ea14b5d1 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Move PpState into PreProcess And initParserState, initPragState too - - - - - 31691fc8 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Process nested include files Also move PpState out of Lexer.x, so it is easy to evolve it in a ghci session, loading utils/check-cpp/Main.hs - - - - - cefc0b99 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Split into separate files - - - - - 7fdb5df3 by Alan Zimmerman at 2025-04-23T18:20:32+01:00 Starting on expression parser. But it hangs. Time for Text.Parsec.Expr - - - - - f6234083 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Start integrating the ghc-cpp work From https://github.com/alanz/ghc-cpp - - - - - f9c295b7 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 WIP - - - - - 81269b9e by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Fixup after rebase - - - - - 79082e9c by Alan Zimmerman at 2025-04-23T18:20:33+01:00 WIP - - - - - a1a2928e by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Fixup after rebase, including all tests pass - - - - - 640d5544 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Change pragma usage to GHC_CPP from GhcCPP - - - - - ca99b0f7 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Some comments - - - - - 1005c070 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Reformat - - - - - 6473a770 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Delete unused file - - - - - d724e532 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Rename module Parse to ParsePP - - - - - ce03ec8d by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Clarify naming in the parser - - - - - 9733b4b6 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 WIP. Switching to alex/happy to be able to work in-tree Since Parsec is not available - - - - - 583e0b18 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Layering is now correct - GHC lexer, emits CPP tokens - accumulated in Preprocessor state - Lexed by CPP lexer, CPP command extracted, tokens concated with spaces (to get rid of token pasting via comments) - if directive lexed and parsed by CPP lexer/parser, and evaluated - - - - - 644dcd5e by Alan Zimmerman at 2025-04-23T18:20:33+01:00 First example working Loading Example1.hs into ghci, getting the right results ``` {-# LANGUAGE GHC_CPP #-} module Example1 where y = 3 x = "hello" "bye now" foo = putStrLn x ``` - - - - - f0c697ec by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Rebase, and all tests pass except whitespace for generated parser - - - - - e98d5c51 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 More plumbing. Ready for testing tomorrow. - - - - - 416afac3 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Proress. Renamed module State from Types And at first blush it seems to handle preprocessor scopes properly. - - - - - 96c3bbfa by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Insert basic GHC version macros into parser __GLASGOW_HASKELL__ __GLASGOW_HASKELL_FULL_VERSION__ __GLASGOW_HASKELL_PATCHLEVEL1__ __GLASGOW_HASKELL_PATCHLEVEL2__ - - - - - 0f44f60b by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Re-sync check-cpp for easy ghci work - - - - - b597d3af by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Get rid of warnings - - - - - e2c95bd2 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Rework macro processing, in check-cpp Macros kept at the top level, looked up via name, multiple arity versions per name can be stored - - - - - 71c8b69b by Alan Zimmerman at 2025-04-23T18:20:33+01:00 WIP. Can crack arguments for #define Next step it to crack out args in an expansion - - - - - 65952a64 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 WIP on arg parsing. - - - - - cc5b7bae by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Progress. Still screwing up nested parens. - - - - - 97cf33ce by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Seems to work, but has redundant code - - - - - 122e4141 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Remove redundant code - - - - - d1cd5d4a by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Reformat - - - - - eae48cdb by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Expand args, single pass Still need to repeat until fixpoint - - - - - 19fa7863 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Fixed point expansion - - - - - 9dcb60a4 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Sync the playground to compiler - - - - - f763146c by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Working on dumping the GHC_CPP result But We need to keep the BufSpan in a comment - - - - - a4b011ef by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Keep BufSpan in queued comments in GHC.Parser.Lexer - - - - - e6217a9d by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Getting close to being able to print the combined tokens showing what is in and what is out - - - - - d88f20db by Alan Zimmerman at 2025-04-23T18:20:33+01:00 First implementation of dumpGhcCpp. Example output First dumps all macros in the state, then the source, showing which lines are in and which are out ------------------------------ - |#define FOO(A,B) A + B - |#define FOO(A,B,C) A + B + C - |#if FOO(1,FOO(3,4)) == 8 - |-- a comment |x = 1 - |#else - |x = 5 - |#endif - - - - - 3e5a0ceb by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Clean up a bit - - - - - f608ef03 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Add -ddump-ghc-cpp option and a test based on it - - - - - f915ca13 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Restore Lexer.x rules, we need them for continuation lines - - - - - f2563161 by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Lexer.x: trying to sort out the span for continuations - We need to match on \n at the end of the line - We cannot simply back up for it - - - - - 42a531cc by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Inserts predefined macros. But does not dump properly Because the cpp tokens have a trailing newline - - - - - a1cc1d0d by Alan Zimmerman at 2025-04-23T18:20:33+01:00 Remove unnecessary LExer rules We *need* the ones that explicitly match to the end of the line. - - - - - 4a83790f by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Generate correct span for ITcpp Dump now works, except we do not render trailing `\` for continuation lines. This is good enough for use in test output. - - - - - 87f30d80 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Reduce duplication in lexer - - - - - cf56bda3 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Tweaks - - - - - 93fd2d62 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Insert min_version predefined macros into state The mechanism now works. Still need to flesh out the full set. - - - - - 32b4ce0c by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Trying my alternative pragma syntax. It works, but dumpGhcCpp is broken, I suspect from the ITcpp token span update. - - - - - ea43b3e5 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Pragma extraction now works, with both CPP and GHC_CPP For the following {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 913 {-# LANGUAGE GHC_CPP #-} #endif We will enable GHC_CPP only - - - - - 28d56603 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Remove some tracing - - - - - 82e3be4f by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Fix test exes for changes - - - - - 94076bba by Alan Zimmerman at 2025-04-23T18:20:34+01:00 For GHC_CPP tests, normalise config-time-based macros - - - - - 006c0eb7 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 WIP - - - - - 2169b0b2 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 WIP again. What is wrong? - - - - - 16aba8e4 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Revert to dynflags for normal not pragma lexing - - - - - 66e7ea5c by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Working on getting check-exact to work properly - - - - - bf5b32e9 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Passes CppCommentPlacement test - - - - - 67b46e02 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Starting on exact printing with GHC_CPP While overriding normal CPP - - - - - 67e5784b by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Correctly store CPP ignored tokens as comments By populating the lexeme string in it, based on the bufpos - - - - - 1ede50b5 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 WIP - - - - - 2494ae3b by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Simplifying - - - - - 8513be6d by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Update the active state logic - - - - - 5497f216 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Work the new logic into the mainline code - - - - - 62907fad by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Process `defined` operator - - - - - d9f18ec7 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Manage lexer state while skipping tokens There is very intricate layout-related state used when lexing. If a CPP directive blanks out some tokens, store this state when the blanking starts, and restore it when they are no longer being blanked. - - - - - 6440b6fd by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Track the last token buffer index, for ITCppIgnored We need to attach the source being skipped in an ITCppIgnored token. We cannot simply use its BufSpan as an index into the underlying StringBuffer as it counts unicode chars, not bytes. So we update the lexer state to store the starting StringBuffer location for the last token, and use the already-stored length to extract the correct portion of the StringBuffer being parsed. - - - - - 94f160f2 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Process the ! operator in GHC_CPP expressions - - - - - 043cd4fc by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Predefine a constant when GHC_CPP is being used. - - - - - 856fc6d8 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 WIP - - - - - 979b586e by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Skip lines directly in the lexer when required - - - - - cf16b372 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Properly manage location when accepting tokens again - - - - - 7147c8aa by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Seems to be working now, for Example9 - - - - - 38b6f99e by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Remove tracing - - - - - 63000ef1 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Fix parsing '*' in block comments Instead of replacing them with '-' - - - - - b8b8683d by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Keep the trailing backslash in a ITcpp token - - - - - 917cf766 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Deal with only enabling one section of a group. A group is an instance of a conditional introduced by #if/#ifdef/#ifndef, and ending at the final #endif, including intermediate #elsif sections - - - - - 8a61cdb0 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Replace remaining identifiers with 0 when evaluating As per the spec - - - - - 8d6e5059 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Snapshot before rebase - - - - - 406f310f by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Skip non-processed lines starting with # - - - - - f09197cd by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Export generateMacros so we can use it in ghc-exactprint - - - - - 4400f575 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Fix rebase - - - - - b3f1b80b by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Expose initParserStateWithMacrosString - - - - - ebd1e495 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Fix buggy lexer cppSkip It was skipping all lines, not just ones prefixed by # - - - - - b209229d by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Fix evaluation of && to use the correct operator - - - - - 59dd06b5 by Alan Zimmerman at 2025-04-23T18:20:34+01:00 Deal with closing #-} at the start of a line - - - - - b15335d6 by Alan Zimmerman at 2025-04-23T18:20:35+01:00 Add the MIN_VERSION_GLASGOW_HASKELL predefined macro - - - - - 2462186e by Alan Zimmerman at 2025-04-23T18:20:35+01:00 Include MIN_VERSION_GLASGOW_HASKELL in GhcCpp01.stderr - - - - - ad5c2dbd by Alan Zimmerman at 2025-04-23T18:20:35+01:00 Use a strict map for macro defines - - - - - 28e8853d by Alan Zimmerman at 2025-04-23T18:20:35+01:00 Process TIdentifierLParen Which only matters at the start of #define - - - - - 5c80a798 by Alan Zimmerman at 2025-04-23T18:20:35+01:00 Do not provide TIdentifierLParen paren twice - - - - - fbcdf374 by Alan Zimmerman at 2025-04-23T18:20:35+01:00 Handle whitespace between identifier and '(' for directive only - - - - - 37b1be80 by Alan Zimmerman at 2025-04-23T18:20:35+01:00 Expose some Lexer bitmap manipulation helpers - - - - - 557ec85d by Alan Zimmerman at 2025-04-23T20:50:22+01:00 Deal with line pragmas as tokens Blows up for dumpGhcCpp though - - - - - 82 changed files: - compiler/GHC.hs - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/Parser/Monad.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/Parser.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Parser.hs-boot - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - + compiler/GHC/Parser/PreProcess.hs - + compiler/GHC/Parser/PreProcess/Eval.hs - + compiler/GHC/Parser/PreProcess/Lexer.x - + compiler/GHC/Parser/PreProcess/Macro.hs - + compiler/GHC/Parser/PreProcess/ParsePP.hs - + compiler/GHC/Parser/PreProcess/Parser.y - + compiler/GHC/Parser/PreProcess/ParserM.hs - + compiler/GHC/Parser/PreProcess/State.hs - compiler/GHC/Parser/Utils.hs - compiler/GHC/SysTools/Cpp.hs - compiler/ghc.cabal.in - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - hadrian/src/Rules/SourceDist.hs - hadrian/stack.yaml.lock - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/driver/T4437.hs - testsuite/tests/ghc-api/T11579.hs - + testsuite/tests/ghc-cpp/GhcCpp01.hs - + testsuite/tests/ghc-cpp/GhcCpp01.stderr - + testsuite/tests/ghc-cpp/all.T - testsuite/tests/interface-stability/template-haskell-exports.stdout - + testsuite/tests/printer/CppCommentPlacement.hs - + testsuite/tests/simplCore/should_compile/T25976.hs - testsuite/tests/simplCore/should_compile/all.T - + utils/check-cpp/.ghci - + utils/check-cpp/.gitignore - + utils/check-cpp/Eval.hs - + utils/check-cpp/Example1.hs - + utils/check-cpp/Example10.hs - + utils/check-cpp/Example11.hs - + utils/check-cpp/Example12.hs - + utils/check-cpp/Example13.hs - + utils/check-cpp/Example2.hs - + utils/check-cpp/Example3.hs - + utils/check-cpp/Example4.hs - + utils/check-cpp/Example5.hs - + utils/check-cpp/Example6.hs - + utils/check-cpp/Example7.hs - + utils/check-cpp/Example8.hs - + utils/check-cpp/Example9.hs - + utils/check-cpp/Lexer.x - + utils/check-cpp/Macro.hs - + utils/check-cpp/Main.hs - + utils/check-cpp/ParsePP.hs - + utils/check-cpp/ParseSimulate.hs - + utils/check-cpp/Parser.y - + utils/check-cpp/ParserM.hs - + utils/check-cpp/PreProcess.hs - + utils/check-cpp/README.md - + utils/check-cpp/State.hs - + utils/check-cpp/run.sh - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Preprocess.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Parser.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c88a8a4bb158989f999278708c9ce7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c88a8a4bb158989f999278708c9ce7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/int-index/enforce-namespaces
by Vladislav Zavialov (＠int-index) 23 Apr '25

23 Apr '25

Vladislav Zavialov pushed new branch wip/int-index/enforce-namespaces at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/enforce-namespaces You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] Expose some Lexer bitmap manipulation helpers
by Alan Zimmerman (＠alanz) 23 Apr '25

23 Apr '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: c88a8a4b by Alan Zimmerman at 2025-04-23T18:18:57+01:00 Expose some Lexer bitmap manipulation helpers - - - - - 1 changed file: - compiler/GHC/Parser/Lexer.x Changes: ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -73,8 +73,8 @@ module GHC.Parser.Lexer ( ExtBits(..), xtest, xunset, xset, disableHaddock, - enableGhcCpp, - ghcCppEnabled, + enableGhcCpp, ghcCppEnabled, + enableExtBit, disableExtBit, extBitEnabled, lexTokenStream, mkParensEpToks, mkParensLocs, @@ -3152,12 +3152,23 @@ disableHaddock opts = upd_bitmap (xunset HaddockBit) upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) } enableGhcCpp :: ParserOpts -> ParserOpts -enableGhcCpp opts = upd_bitmap (xset GhcCppBit) +enableGhcCpp = enableExtBit GhcCppBit + +ghcCppEnabled :: ParserOpts -> Bool +ghcCppEnabled = extBitEnabled GhcCppBit + +enableExtBit :: ExtBits -> ParserOpts -> ParserOpts +enableExtBit bit opts = upd_bitmap (xset bit) where upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) } -ghcCppEnabled :: ParserOpts -> Bool -ghcCppEnabled opts = xtest GhcCppBit (pExtsBitmap opts) +disableExtBit :: ExtBits -> ParserOpts -> ParserOpts +disableExtBit bit opts = upd_bitmap (xunset bit) + where + upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) } + +extBitEnabled :: ExtBits -> ParserOpts -> Bool +extBitEnabled bit opts = xtest bit (pExtsBitmap opts) -- | Set parser options for parsing OPTIONS pragmas initPragState :: p -> ParserOpts -> StringBuffer -> RealSrcLoc -> PState p View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c88a8a4bb158989f999278708c9ce7c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c88a8a4bb158989f999278708c9ce7c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Move -fno-code note into Downsweep module
by Marge Bot (＠marge-bot) 23 Apr '25

23 Apr '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 7250fc0c by Matthew Pickering at 2025-04-22T16:24:04-04:00 Move -fno-code note into Downsweep module This note was left behind when all the code which referred to it was moved into the GHC.Driver.Downsweep module - - - - - d2dc89b4 by Matthew Pickering at 2025-04-22T16:24:04-04:00 Apply editing notes to Note [-fno-code mode] suggested by sheaf These notes were suggested in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14241 - - - - - cd848c75 by Matthew Pickering at 2025-04-23T12:18:00-04:00 ghci: Use loadInterfaceForModule rather than loadSrcInterface in mkTopLevEnv loadSrcInterface takes a user given `ModuleName` and resolves it to the module which needs to be loaded (taking into account module renaming/visibility etc). loadInterfaceForModule takes a specific module and loads it. The modules in `ImpDeclSpec` have already been resolved to the actual module to get the information from during renaming. Therefore we just need to fetch the precise interface from disk (and not attempt to rename it again). Fixes #25951 - - - - - df8442ae by Simon Peyton Jones at 2025-04-23T12:18:01-04:00 Test for #23298 - - - - - 10 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Runtime/Eval.hs - + testsuite/tests/gadt/T23298.hs - + testsuite/tests/gadt/T23298.stderr - testsuite/tests/gadt/all.T - + testsuite/tests/ghci/scripts/GhciPackageRename.hs - + testsuite/tests/ghci/scripts/GhciPackageRename.script - + testsuite/tests/ghci/scripts/GhciPackageRename.stdout - testsuite/tests/ghci/scripts/all.T Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -947,6 +947,71 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do hostFullWays in dflags_c +{- Note [-fno-code mode] +~~~~~~~~~~~~~~~~~~~~~~~~ +GHC offers the flag -fno-code for the purpose of parsing and typechecking a +program without generating object files. This is intended to be used by tooling +and IDEs to provide quick feedback on any parser or type errors as cheaply as +possible. + +When GHC is invoked with -fno-code, no object files or linked output will be +generated. As many errors and warnings as possible will be generated, as if +-fno-code had not been passed. The session DynFlags will have +backend == NoBackend. + +-fwrite-interface +~~~~~~~~~~~~~~~~ +Whether interface files are generated in -fno-code mode is controlled by the +-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is +not also passed. Recompilation avoidance requires interface files, so passing +-fno-code without -fwrite-interface should be avoided. If -fno-code were +re-implemented today, there would be no need for -fwrite-interface as it +would considered always on; this behaviour is as it is for backwards compatibility. + +================================================================ +IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER +================================================================ + +Template Haskell +~~~~~~~~~~~~~~~~ +A module using Template Haskell may invoke an imported function from inside a +splice. This will cause the type-checker to attempt to execute that code, which +would fail if no object files had been generated. See #8025. To rectify this, +during the downsweep we patch the DynFlags in the ModSummary of any home module +that is imported by a module that uses Template Haskell to generate object +code. + +The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled +or not in the module which needs the code generation. If the module requires byte-code then +dependencies will generate byte-code, otherwise they will generate object files. +In the case where some modules require byte-code and some object files, both are +generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these +configurations. + +The object files (and interface files if -fwrite-interface is disabled) produced +for Template Haskell are written to temporary files. + +Note that since Template Haskell can run arbitrary IO actions, -fno-code mode +is no more secure than running without it. + +Potential TODOS: +~~~~~ +* Remove -fwrite-interface and have interface files always written in -fno-code + mode +* Both .o and .dyn_o files are generated for template haskell, but we only need + .dyn_o. Fix it. +* In make mode, a message like + Compiling A (A.hs, /tmp/ghc_123.o) + is shown if downsweep enabled object code generation for A. Perhaps we should + show "nothing" or "temporary object file" instead. Note that one + can currently use -keep-tmp-files and inspect the generated file with the + current behaviour. +* Offer a -no-codedir command line option, and write what were temporary + object files there. This would speed up recompilation. +* Use existing object files (if they are up to date) instead of always + generating temporary ones. +-} + -- | Populate the Downsweep cache with the root modules. mkRootMap :: [ModuleNodeInfo] ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1246,70 +1246,6 @@ addSptEntries hsc_env mlinkable = , spt <- bc_spt_entries bco ] -{- Note [-fno-code mode] -~~~~~~~~~~~~~~~~~~~~~~~~ -GHC offers the flag -fno-code for the purpose of parsing and typechecking a -program without generating object files. This is intended to be used by tooling -and IDEs to provide quick feedback on any parser or type errors as cheaply as -possible. - -When GHC is invoked with -fno-code no object files or linked output will be -generated. As many errors and warnings as possible will be generated, as if --fno-code had not been passed. The session DynFlags will have -backend == NoBackend. - --fwrite-interface -~~~~~~~~~~~~~~~~ -Whether interface files are generated in -fno-code mode is controlled by the --fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is -not also passed. Recompilation avoidance requires interface files, so passing --fno-code without -fwrite-interface should be avoided. If -fno-code were -re-implemented today, -fwrite-interface would be discarded and it would be -considered always on; this behaviour is as it is for backwards compatibility. - -================================================================ -IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER -================================================================ - -Template Haskell -~~~~~~~~~~~~~~~~ -A module using template haskell may invoke an imported function from inside a -splice. This will cause the type-checker to attempt to execute that code, which -would fail if no object files had been generated. See #8025. To rectify this, -during the downsweep we patch the DynFlags in the ModSummary of any home module -that is imported by a module that uses template haskell, to generate object -code. - -The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled -or not in the module which needs the code generation. If the module requires byte-code then -dependencies will generate byte-code, otherwise they will generate object files. -In the case where some modules require byte-code and some object files, both are -generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these -configurations. - -The object files (and interface files if -fwrite-interface is disabled) produced -for template haskell are written to temporary files. - -Note that since template haskell can run arbitrary IO actions, -fno-code mode -is no more secure than running without it. - -Potential TODOS: -~~~~~ -* Remove -fwrite-interface and have interface files always written in -fno-code - mode -* Both .o and .dyn_o files are generated for template haskell, but we only need - .dyn_o. Fix it. -* In make mode, a message like - Compiling A (A.hs, /tmp/ghc_123.o) - is shown if downsweep enabled object code generation for A. Perhaps we should - show "nothing" or "temporary object file" instead. Note that one - can currently use -keep-tmp-files and inspect the generated file with the - current behaviour. -* Offer a -no-codedir command line option, and write what were temporary - object files there. This would speed up recompilation. -* Use existing object files (if they are up to date) instead of always - generating temporary ones. --} -- Note [When source is considered modified] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -78,7 +78,7 @@ import GHC.Core.Type hiding( typeKind ) import qualified GHC.Core.Type as Type import GHC.Iface.Env ( newInteractiveBinder ) -import GHC.Iface.Load ( loadSrcInterface ) +import GHC.Iface.Load ( loadInterfaceForModule ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin @@ -843,7 +843,7 @@ mkTopLevEnv hsc_env modl $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv) $ forM imports $ \iface_import -> do let ImpUserSpec spec details = tcIfaceImport iface_import - iface <- loadSrcInterface (text "imported by GHCi") (moduleName $ is_mod spec) (is_isboot spec) (is_pkg_qual spec) + iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec) pure $ case details of ImpUserAll -> importsFromIface hsc_env iface spec Nothing ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns) ===================================== testsuite/tests/gadt/T23298.hs ===================================== @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} +module T23298 where + +import Data.Kind (Type) + +type HList :: Type -> Type +data HList a where + HCons :: HList x -> HList (Maybe x) + +eq :: HList a -> Bool +eq x = case x of + HCons ms -> True + +go (HCons x) = go x + +{- go :: HList alpha -> beta + +Under HCons + [G] alpha ~ Maybe x + [W] HList x ~ HList alpha +==> + [W] x ~ alpha +==> + [W] x ~ Maybe x +-} ===================================== testsuite/tests/gadt/T23298.stderr ===================================== @@ -0,0 +1,12 @@ + T23298.hs:14:16: error: [GHC-25897] + • Couldn't match type ‘x’ with ‘Maybe x’ + Expected: HList x -> t + Actual: HList a -> t + ‘x’ is a rigid type variable bound by + a pattern with constructor: + HCons :: forall x. HList x -> HList (Maybe x), + in an equation for ‘go’ + at T23298.hs:14:5-11 + • In the expression: go x + In an equation for ‘go’: go (HCons x) = go x + • Relevant bindings include x :: HList x (bound at T23298.hs:14:11) ===================================== testsuite/tests/gadt/all.T ===================================== @@ -131,3 +131,4 @@ test('T19847a', normalise_version('base'), compile, ['-ddump-types']) test('T19847b', normal, compile, ['']) test('T23022', normal, compile, ['-dcore-lint']) test('T23023', normal, compile_fail, ['-O -dcore-lint']) # todo: move this test? +test('T23298', normal, compile_fail, ['']) ===================================== testsuite/tests/ghci/scripts/GhciPackageRename.hs ===================================== @@ -0,0 +1,4 @@ +module GhciPackageRename where + +foo :: Map k v +foo = empty \ No newline at end of file ===================================== testsuite/tests/ghci/scripts/GhciPackageRename.script ===================================== @@ -0,0 +1,6 @@ +:l GhciPackageRename.hs +-- Test that Data.Map is available as Prelude +:t fromList + +-- Test using a Map function +fromList [(1,"a"), (2,"b")] \ No newline at end of file ===================================== testsuite/tests/ghci/scripts/GhciPackageRename.stdout ===================================== @@ -0,0 +1,3 @@ +fromList + :: ghc-internal:GHC.Internal.Classes.Ord k => [(k, a)] -> Map k a +fromList [(1,"a"),(2,"b")] ===================================== testsuite/tests/ghci/scripts/all.T ===================================== @@ -386,3 +386,9 @@ test('T13869', extra_files(['T13869a.hs', 'T13869b.hs']), ghci_script, ['T13869. test('ListTuplePunsPpr', normal, ghci_script, ['ListTuplePunsPpr.script']) test('ListTuplePunsPprNoAbbrevTuple', [expect_broken(23135), limit_stdout_lines(13)], ghci_script, ['ListTuplePunsPprNoAbbrevTuple.script']) test('T24459', normal, ghci_script, ['T24459.script']) + +# Test package renaming in GHCi session +test('GhciPackageRename', + [extra_hc_opts("-hide-all-packages -package 'containers (Data.Map as Prelude)'")], + ghci_script, + ['GhciPackageRename.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4e09173636dc453b10cf8949f96cf2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4e09173636dc453b10cf8949f96cf2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/splice-imports-2025] Fix docs
by Matthew Pickering (＠mpickering) 23 Apr '25

23 Apr '25

Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC Commits: 0aac7dcc by Matthew Pickering at 2025-04-23T17:09:53+01:00 Fix docs - - - - - 2 changed files: - compiler/GHC/Driver/Session.hs - docs/users_guide/using-warnings.rst Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2265,6 +2265,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect" Opt_WarnCPPUndef -> warnSpec x Opt_WarnBadlyLevelledTypes -> + warnSpec x ++ subWarnSpec "badly-staged-types" x "it is renamed to -Wbadly-levelled-types" Opt_WarnUnbangedStrictPatterns -> warnSpec x Opt_WarnDeferredTypeErrors -> warnSpec x ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2554,7 +2554,7 @@ of ``-W(no-)*``. that are not deprecating a name that is deprecated with another export in that module. .. ghc-flag:: -Wbadly-levelled-types - :shortdesc: warn when type binding is used at the wrong TH stage. + :shortdesc: warn when type binding is used at the wrong Template Haskell level. :type: dynamic :reverse: -Wno-badly-levelled-types @@ -2565,11 +2565,21 @@ of ``-W(no-)*``. tardy :: forall a. Proxy a -> IO Type tardy _ = [t| a |] - The type binding ``a`` is bound at stage 1 but used on stage 2. + The type binding ``a`` is bound at level 0 but used at level 1. - This is badly staged program, and the ``tardy (Proxy @Int)`` won't produce + This is badly levelled program, and the ``tardy (Proxy @Int)`` won't produce a type representation of ``Int``, but rather a local name ``a``. +.. ghc-flag:: -Wbadly-staged-types + :shortdesc: A deprecated alias for :ghc-flag:`-Wbadly-levelled-types` + :type: dynamic + :reverse: -Wno-badly-staged-types + + :since: 9.10.1 + + A deprecated alias for :ghc-flag:`-Wbadly-levelled-types` + + .. ghc-flag:: -Winconsistent-flags :shortdesc: warn when command line options are inconsistent in some way. :type: dynamic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0aac7dcc195371d7ce82eac0f10d427… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0aac7dcc195371d7ce82eac0f10d427… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25898
by Ben Gamari (＠bgamari) 23 Apr '25

23 Apr '25

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

1 0

[Git][ghc/ghc] Pushed new branch wip/T25968
by Ben Gamari (＠bgamari) 23 Apr '25

23 Apr '25

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

1 0

[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 2 commits: Use Module in IIModule
by Hannes Siebenhandl (＠fendor) 23 Apr '25

23 Apr '25

Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC Commits: b7b39d81 by fendor at 2025-04-23T17:50:25+02:00 Use Module in IIModule - - - - - 6e49609d by fendor at 2025-04-23T17:50:25+02:00 WIP - - - - - 20 changed files: - compiler/GHC.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Home/Graph.hs - ghc/GHCi/UI.hs - testsuite/tests/ghci/linking/dyn/T3372.hs - testsuite/tests/ghci/prog018/prog018.stdout - testsuite/tests/ghci/scripts/T13869.stdout - testsuite/tests/ghci/scripts/T13997.stdout - testsuite/tests/ghci/scripts/T17669.stdout - testsuite/tests/ghci/scripts/T18330.stdout - testsuite/tests/ghci/scripts/T1914.stdout - testsuite/tests/ghci/scripts/T20217.stdout - testsuite/tests/ghci/scripts/T20587.stdout - testsuite/tests/ghci/scripts/T6105.stdout - testsuite/tests/ghci/scripts/T8042.stdout - testsuite/tests/ghci/scripts/T8042recomp.stdout - testsuite/tests/ghci/should_run/TopEnvIface.stdout Changes: ===================================== compiler/GHC.hs ===================================== @@ -40,6 +40,7 @@ module GHC ( getProgramDynFlags, setProgramDynFlags, updateProgramDynFlags, getInteractiveDynFlags, setInteractiveDynFlags, + normaliseInteractiveDynFlags, initialiseInteractiveDynFlags, interpretPackageEnv, -- * Logging @@ -157,7 +158,7 @@ module GHC ( getBindings, getInsts, getNamePprCtx, findModule, lookupModule, findQualifiedModule, lookupQualifiedModule, - lookupLoadedHomeModuleByModuleName, lookupAnyQualifiedModule, + lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames, renamePkgQualM, renameRawPkgQualM, isModuleTrusted, moduleTrustReqs, getNamesInScope, @@ -962,24 +963,8 @@ getProgramDynFlags = getSessionDynFlags setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do logger <- getLogger - dflags' <- checkNewDynFlags logger dflags - dflags'' <- checkNewInteractiveDynFlags logger dflags' - modifySessionM $ \hsc_env0 -> do - let ic0 = hsc_IC hsc_env0 - - -- Initialise (load) plugins in the interactive environment with the new - -- DynFlags - plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ - hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }} - - -- Update both plugins cache and DynFlags in the interactive context. - return $ hsc_env0 - { hsc_IC = ic0 - { ic_plugins = hsc_plugins plugin_env - , ic_dflags = hsc_dflags plugin_env - } - } - + icdflags <- normaliseInteractiveDynFlags logger dflags + modifySessionM (initialiseInteractiveDynFlags icdflags) -- | Get the 'DynFlags' used to evaluate interactive expressions. getInteractiveDynFlags :: GhcMonad m => m DynFlags @@ -1084,6 +1069,28 @@ normalise_hyp fp ----------------------------------------------------------------------------- +normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +normaliseInteractiveDynFlags logger dflags = do + dflags' <- checkNewDynFlags logger dflags + checkNewInteractiveDynFlags logger dflags' + +initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv +initialiseInteractiveDynFlags dflags hsc_env0 = do + let ic0 = hsc_IC hsc_env0 + + -- Initialise (load) plugins in the interactive environment with the new + -- DynFlags + plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ + hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags }} + + -- Update both plugins cache and DynFlags in the interactive context. + return $ hsc_env0 + { hsc_IC = ic0 + { ic_plugins = hsc_plugins plugin_env + , ic_dflags = hsc_dflags plugin_env + } + } + -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible). @@ -1496,8 +1503,8 @@ getModuleGraph = liftM hsc_mod_graph getSession -- TODO: this function should likely be deleted. isLoaded :: GhcMonad m => ModuleName -> m Bool isLoaded m = withSession $ \hsc_env -> liftIO $ do - hmi <- HUG.lookupAnyHug (hsc_HUG hsc_env) m - return $! isJust hmi + hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m + return $! not (null hmis) isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do @@ -1895,18 +1902,16 @@ lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing --- TODO: this is incorrect, what if we have mulitple 'ModuleName's in our HPTs? -lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module]) lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name) - HUG.lookupAnyHug (hsc_HUG hsc_env) mod_name >>= \case - Just mod_info -> return (Just (mi_module (hm_iface mod_info))) - _not_a_home_module -> return Nothing + HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case + [] -> return Nothing + mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos)) -lookupAnyQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module -lookupAnyQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do +lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module] +lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do home <- lookupLoadedHomeModuleByModuleName mod_name - liftIO $ trace_if (hsc_logger hsc_env) (ppr home <+> ppr (fmap moduleUnitId home)) case home of Just m -> return m Nothing -> liftIO $ do @@ -1916,11 +1921,11 @@ lookupAnyQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do let fopts = initFinderOpts dflags res <- findExposedPackageModule fc fopts units mod_name NoPkgQual case res of - Found _ m -> return m + Found _ m -> return [m] err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err -lookupAnyQualifiedModule pkgqual mod_name = - -- TODO: definitely wrong. - findQualifiedModule pkgqual mod_name +lookupAllQualifiedModuleNames pkgqual mod_name = do + m <- findQualifiedModule pkgqual mod_name + pure [m] -- | Check that a module is safe to import (according to Safe Haskell). -- ===================================== compiler/GHC/Rename/Unbound.hs ===================================== @@ -364,7 +364,7 @@ importSuggestions looking_for ic currMod imports rdr_name pick_interactive :: InteractiveImport -> Bool pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True | mod_name == fmap unLoc (ideclAs d) = True - pick_interactive (IIModule m) | mod_name == Just m = True + pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True pick_interactive _ = False -- We want to keep only one for each original module; preferably one with an ===================================== compiler/GHC/Runtime/Context.hs ===================================== @@ -296,9 +296,7 @@ data InteractiveImport -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope - | IIModule ModuleName - -- TODO: change this to 'Module', does this work? - -- Much more precise + | IIModule Module -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -822,17 +822,12 @@ findGlobalRdrEnv hsc_env imports idecls :: [LImportDecl GhcPs] idecls = [noLocA d | IIDecl d <- imports] - imods :: [ModuleName] + imods :: [Module] imods = [m | IIModule m <- imports] - mkEnv modl = do - -- TODO: revisit this, is this how we want to do it? - mMod <- HUG.lookupAnyHug (hsc_HUG hsc_env) modl - let mod = case mMod of - Nothing -> mkModule (RealUnit $ Definite $ hscActiveUnitId hsc_env) modl - Just m -> mi_module $ hm_iface m + mkEnv mod = do mkTopLevEnv hsc_env mod >>= \case - Left err -> pure $ Left (modl, err) + Left err -> pure $ Left (moduleName mod, err) Right env -> pure $ Right env mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -150,7 +150,6 @@ import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Types.Annotations import GHC.Types.SrcLoc import GHC.Types.SourceFile -import GHC.Types.PkgQual import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Env as UnitEnv @@ -2091,15 +2090,18 @@ runTcInteractive hsc_env thing_inside , let local_gres = filter isLocalGRE gres , not (null local_gres) ]) ] - ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) - (loadSrcInterface (text "runTcInteractive") m - NotBoot mb_pkg) + ; let getOrphansForModuleName m mb_pkg = do + iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg + pure $ mi_module iface : dep_orphs (mi_deps iface) + + getOprhansForModule m = do + iface <- loadModuleInterface (text "runTcInteractive") m + pure $ mi_module iface : dep_orphs (mi_deps iface) ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111 - IIModule n -> getOrphans n NoPkgQual - IIDecl i -> getOrphans (unLoc (ideclName i)) + IIModule n -> getOprhansForModule n + IIDecl i -> getOrphansForModuleName (unLoc (ideclName i)) (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -34,7 +34,7 @@ module GHC.Unit.Home.Graph , lookupHug , lookupHugByModule , lookupHugUnit - , lookupAnyHug + , lookupAllHug , memberHugHomeModule , memberHugHomeInstalledModule @@ -91,6 +91,7 @@ import GHC.Data.Graph.Directed import GHC.Types.Annotations import GHC.Types.CompleteMatch import GHC.Core.InstEnv +import GHC.Utils.Monad (mapMaybeM) -- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across @@ -254,22 +255,17 @@ lookupHug hug uid mod = do Nothing -> pure Nothing Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod --- TODO: this should not be merged, where else could we try to search for modules? -lookupAnyHug :: HomeUnitGraph -> ModuleName -> IO (Maybe HomeModInfo) -lookupAnyHug hug mod = firstJustM $ flip fmap (Set.toList $ unitEnv_keys hug) $ \uid -> do - case unitEnv_lookup_maybe uid hug of - -- Really, here we want "lookup HPT" rather than unitEnvLookup - Nothing -> pure Nothing - Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod +-- | Lookup all 'HomeModInfo' that have the same 'ModuleName' as the given 'ModuleName'. +-- 'ModuleName's are not unique in the case of multiple home units, so there can be +-- more than one possible 'HomeModInfo'. +lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo] +lookupAllHug hug mod = mapMaybeM lookupModuleName (Set.toList $ unitEnv_keys hug) where - firstJustM :: Monad f => [f (Maybe a)] -> f (Maybe a) - firstJustM [] = pure Nothing - firstJustM (x:xs) = do - ma <- x - case ma of - Nothing -> firstJustM xs - Just a -> pure $ Just a - + lookupModuleName uid = + case unitEnv_lookup_maybe uid hug of + -- Really, here we want "lookup HPT" rather than unitEnvLookup + Nothing -> pure Nothing + Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod -- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit) lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo) @@ -283,10 +279,12 @@ lookupHugByModule mod hug lookupHugUnit :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv lookupHugUnit = unitEnv_lookup_maybe +-- | Check whether the 'Module' is part of the given 'HomeUnitGraph'. memberHugHomeModule :: Module -> HomeUnitGraph -> Bool memberHugHomeModule mod = memberHugHomeInstalledModule (fmap toUnitId mod) +-- | Check whether the 'InstalledModule' is part of the given 'HomeUnitGraph'. memberHugHomeInstalledModule :: InstalledModule -> HomeUnitGraph -> Bool memberHugHomeInstalledModule mod hug = case unitEnv_lookup_maybe (moduleUnit mod) hug of ===================================== ghc/GHCi/UI.hs ===================================== @@ -558,7 +558,7 @@ interactiveUI config srcs maybe_exprs = do hsc_env <- GHC.getSession let !in_multi = length (hsc_all_home_unit_ids hsc_env) > 3 -- We force this to make sure we don't retain the hsc_env when reloading - -- The check is `> 2`, since we now always have at least two home units. + -- The check is `> 3`, since we now always have at least two home units. -- TODO: if everything goes well, this check should be deleted once -- this PR has lifted the multiple home unit restrictions empty_cache <- liftIO newIfaceCache @@ -1023,7 +1023,7 @@ getInfoForPrompt = do | otherwise = unLoc (ideclName d) modules_names = - ['*':(moduleNameString m) | IIModule m <- rev_imports] ++ + ['*':(moduleNameString (moduleName m)) | IIModule m <- rev_imports] ++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports] line = 1 + line_number st @@ -1444,7 +1444,6 @@ runStmt input step = do setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500 setDumpFilePrefix ic = do - -- TODO: wrong dflags <- GHC.getInteractiveDynFlags GHC.setInteractiveDynFlags dflags { dumpPrefix = modStr ++ "." } where @@ -2122,7 +2121,7 @@ addModule :: GhciMonad m => [FilePath] -> m () addModule files = do revertCAFs -- always revert CAFs on load/add. files' <- mapM expandPath files - targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files' + targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files' targets' <- filterM checkTarget targets -- remove old targets with the same id; e.g. for :add *M mapM_ GHC.removeTarget [ tid | Target { targetId = tid } <- targets' ] @@ -2155,7 +2154,7 @@ addModule files = do unAddModule :: GhciMonad m => [FilePath] -> m () unAddModule files = do files' <- mapM expandPath files - targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files' + targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files' let removals = [ tid | Target { targetId = tid } <- targets ] mapM_ GHC.removeTarget removals _ <- doLoadAndCollectInfo (Unadd $ length removals) LoadAllTargets @@ -2279,7 +2278,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do -- We import the module with a * iff -- - it is interpreted, and -- - -XSafe is off (it doesn't allow *-imports) - let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)] + let new_ctx | star_ok = [mkIIModule m] | otherwise = [mkIIDecl (GHC.moduleName m)] setContextKeepingPackageModules keep_ctxt new_ctx @@ -2699,7 +2698,7 @@ guessCurrentModule cmd = do imports <- GHC.getContext case imports of [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module") - IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m + IIModule m : _ -> pure m IIDecl d : _ -> do pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d) GHC.findQualifiedModule pkgqual (unLoc (ideclName d)) @@ -2829,8 +2828,9 @@ addModulesToContext starred unstarred = restoreContextOnFailure $ do addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m () addModulesToContext_ starred unstarred = do - mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred) - setGHCContextFromGHCiState + starredModules <- traverse lookupModuleName starred + mapM_ addII (map mkIIModule starredModules ++ map mkIIDecl unstarred) + setGHCContextFromGHCiState remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m () remModulesFromContext starred unstarred = do @@ -2896,9 +2896,9 @@ checkAdd ii = do dflags <- getDynFlags let safe = safeLanguageOn dflags case ii of - IIModule modname + IIModule mod | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell" - | otherwise -> wantInterpretedModuleName modname >> return () + | otherwise -> checkInterpretedModule mod >> return () IIDecl d -> do let modname = unLoc (ideclName d) @@ -2966,13 +2966,13 @@ getImplicitPreludeImports iidecls = do -- ----------------------------------------------------------------------------- -- Utils on InteractiveImport -mkIIModule :: ModuleName -> InteractiveImport +mkIIModule :: Module -> InteractiveImport mkIIModule = IIModule mkIIDecl :: ModuleName -> InteractiveImport mkIIDecl = IIDecl . simpleImportDecl -iiModules :: [InteractiveImport] -> [ModuleName] +iiModules :: [InteractiveImport] -> [Module] iiModules is = [m | IIModule m <- is] isIIModule :: InteractiveImport -> Bool @@ -2980,7 +2980,7 @@ isIIModule (IIModule _) = True isIIModule _ = False iiModuleName :: InteractiveImport -> ModuleName -iiModuleName (IIModule m) = m +iiModuleName (IIModule m) = moduleName m iiModuleName (IIDecl d) = unLoc (ideclName d) preludeModuleName :: ModuleName @@ -3239,22 +3239,30 @@ newDynFlags interactive_only minus_opts = do let oldFlags = HUG.homeUnitEnv_dflags homeUnitEnv -- TODO: perhaps write custom version of parseDynamicFlagsCmdLine which gives us more control over the errors and warnings (newFlags, _, _) <- DynFlags.parseDynamicFlagsCmdLine logger oldFlags lopts - let newFlags' = if uid == interactiveGhciUnitId - then wopt_unset newFlags Opt_WarnUnusedPackages - else newFlags + newFlags' <- + if uid == interactiveGhciUnitId || uid == interactiveSessionUnitId + then do + -- TODO: document this + let dflags1 = wopt_unset newFlags Opt_WarnUnusedPackages + if uid == interactiveGhciUnitId + then + GHC.normaliseInteractiveDynFlags logger dflags1 + else + pure dflags1 + else + pure newFlags pure (uid, oldFlags, newFlags') must_reload <- GHC.updateProgramDynFlags True updates -- update and check interactive dynflags -- TODO: document the relation ship between the interactive unit and in the interactive context icdflags <- hsc_dflags <$> GHC.getSession - GHC.setInteractiveDynFlags icdflags + modifySessionM (GHC.initialiseInteractiveDynFlags icdflags) -- if the package flags changed, reset the context and link -- the new packages. hsc_env <- GHC.getSession let dflags2 = hsc_dflags hsc_env - let interp = hscInterp hsc_env when must_reload $ do when (verbosity dflags2 > 0) $ liftIO . putStrLn $ @@ -3263,30 +3271,41 @@ newDynFlags interactive_only minus_opts = do -- Clear caches and eventually defined breakpoints. (#1620) clearCaches - let units = concatMap (preloadUnits . HUG.homeUnitEnv_units) (Foldable.toList $ hsc_HUG hsc_env) - liftIO $ Loader.loadPackages interp hsc_env units - -- package flags changed, we can't re-use any of the old context - setContextAfterLoad False Nothing -- TODO: recheck whether this is necessary - - -- TODO extract into separate function - let ld0length = length $ ldInputs dflags0 - fmrk0length = length $ cmdlineFrameworks dflags0 - - newLdInputs = drop ld0length (ldInputs dflags2) - newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2) + reloadPackages hsc_env - dflags' = dflags2 { ldInputs = newLdInputs - , cmdlineFrameworks = newCLFrameworks - } - hsc_env' = hscSetFlags dflags' hsc_env - - when (not (null newLdInputs && null newCLFrameworks)) $ - liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env' + reloadLinkerOptions hsc_env dflags0 dflags2 idflags <- hsc_dflags <$> GHC.getSession installInteractivePrint (interactivePrint idflags) False return () +reloadPackages :: GhciMonad m => HscEnv -> m () +reloadPackages hsc_env = do + let + units = + concatMap (preloadUnits . HUG.homeUnitEnv_units) + (Foldable.toList $ hsc_HUG hsc_env) + liftIO $ Loader.loadPackages (hscInterp hsc_env) hsc_env units + -- package flags changed, we can't re-use any of the old context + setContextAfterLoad False Nothing + +reloadLinkerOptions :: MonadIO m => HscEnv -> DynFlags -> DynFlags -> m () +reloadLinkerOptions hsc_env old_flags new_flags = do + let + + ld0length = length $ ldInputs old_flags + fmrk0length = length $ cmdlineFrameworks old_flags + + newLdInputs = drop ld0length (ldInputs new_flags) + newCLFrameworks = drop fmrk0length (cmdlineFrameworks new_flags) + + dflags' = new_flags { ldInputs = newLdInputs + , cmdlineFrameworks = newCLFrameworks + } + hsc_env' = hscSetFlags dflags' hsc_env + + when (not (null newLdInputs && null newCLFrameworks)) $ + liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env' unknownFlagsErr :: GhciMonad m => [String] -> m () unknownFlagsErr fs = mapM_ (\f -> reportError (GhciUnknownFlag f (suggestions f))) fs @@ -3428,7 +3447,7 @@ showImports = do trans_ctx = transient_ctx st show_one (IIModule star_m) - = ":module +*" ++ moduleNameString star_m + = ":module +*" ++ moduleNameString (moduleName star_m) show_one (IIDecl imp) = showPpr dflags imp prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx) @@ -3734,11 +3753,11 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 filterM GHC.moduleIsInterpreted hmods -- Return all possible bids for a given Module - bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String] + bidsByModule :: GhciMonad m => [Module] -> Module -> m [String] bidsByModule nonquals mod = do (_, decls) <- getModBreak mod let bids = nub $ declPath <$> elems decls - pure $ case (moduleName mod) `elem` nonquals of + pure $ case mod `elem` nonquals of True -> bids False -> (combineModIdent (showModule mod)) <$> bids @@ -4143,8 +4162,7 @@ breakSwitch (arg1:rest) | all isDigit arg1 = do imports <- GHC.getContext case iiModules imports of - (mn : _) -> do - md <- lookupModuleName mn + (md : _) -> do breakByModuleLine md (read arg1) rest [] -> do liftIO $ putStrLn "No modules are loaded with debugging support." @@ -4276,8 +4294,7 @@ list2 [arg] | all isDigit arg = do case iiModules imports of [] -> liftIO $ putStrLn "No module to list" (mn : _) -> do - md <- lookupModuleName mn - listModuleLine md (read arg) + listModuleLine mn (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do md <- wantInterpretedModule arg1 listModuleLine md (read arg2) @@ -4536,7 +4553,17 @@ lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module -lookupQualifiedModuleName = GHC.lookupAnyQualifiedModule +lookupQualifiedModuleName qual modl = do + GHC.lookupAllQualifiedModuleNames qual modl >>= \case + [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found.")) + [m] -> pure m + ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous;\n" ++ errorMsg ms)) + where + str = moduleNameString modl + errorMsg ms = intercalate "\n" + [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) + | m <- ms + ] isMainUnitModule :: Module -> Bool isMainUnitModule m = GHC.moduleUnit m == mainUnit @@ -4586,15 +4613,19 @@ wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module wantInterpretedModuleName modname = do - modl <- lookupModuleName modname - let str = moduleNameString modname - hug <- hsc_HUG <$> GHC.getSession - unless (HUG.memberHugHomeModule modl hug) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) - is_interpreted <- GHC.moduleIsInterpreted modl - when (not is_interpreted) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) - return modl + modl <- lookupModuleName modname + checkInterpretedModule modl + +checkInterpretedModule :: GHC.GhcMonad m => Module -> m Module +checkInterpretedModule modl = do + let str = moduleNameString $ moduleName modl + hug <- hsc_HUG <$> GHC.getSession + unless (HUG.memberHugHomeModule modl hug) $ + throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) + is_interpreted <- GHC.moduleIsInterpreted modl + when (not is_interpreted) $ + throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) + return modl wantNameFromInterpretedModule :: GHC.GhcMonad m => (Name -> SDoc -> m ()) ===================================== testsuite/tests/ghci/linking/dyn/T3372.hs ===================================== @@ -60,7 +60,7 @@ load (f,mn) = do target <- GHC.guessTarget f Nothing Nothing GHC.liftIO $ putStrLn ("Load " ++ showSuccessFlag res) -- m <- GHC.findModule (GHC.mkModuleName mn) Nothing - GHC.setContext [GHC.IIModule $ GHC.moduleName $ m] + GHC.setContext [GHC.IIModule m] where showSuccessFlag GHC.Succeeded = "succeeded" showSuccessFlag GHC.Failed = "failed" ===================================== testsuite/tests/ghci/prog018/prog018.stdout ===================================== @@ -1,6 +1,6 @@ -[1 of 3] Compiling A ( A.hs, interpreted ) -[2 of 3] Compiling B ( B.hs, interpreted ) -[3 of 3] Compiling C ( C.hs, interpreted ) +[1 of 3] Compiling A ( A.hs, interpreted )[main] +[2 of 3] Compiling B ( B.hs, interpreted )[main] +[3 of 3] Compiling C ( C.hs, interpreted )[interactive-session] A.hs:5:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In an equation for ‘incompletePattern’: @@ -18,7 +18,7 @@ C.hs:6:7: error: [GHC-88464] Variable not in scope: variableNotInScope :: () Failed, two modules loaded. -[3 of 3] Compiling C ( C.hs, interpreted ) +[3 of 3] Compiling C ( C.hs, interpreted )[interactive-session] C.hs:6:7: error: [GHC-88464] Variable not in scope: variableNotInScope :: () ===================================== testsuite/tests/ghci/scripts/T13869.stdout ===================================== @@ -1,14 +1,14 @@ -[1 of 1] Compiling T13869A ( T13869a.hs, interpreted ) +[1 of 1] Compiling T13869A ( T13869a.hs, interpreted )[interactive-session] Ok, one module loaded. Ok, one module reloaded. Ok, unloaded all modules. Ok, no modules to be reloaded. -[1 of 1] Compiling T13869A ( T13869a.hs, interpreted ) +[1 of 1] Compiling T13869A ( T13869a.hs, interpreted )[interactive-session] Ok, one module loaded. -[2 of 2] Compiling T13869B ( T13869b.hs, interpreted ) +[2 of 2] Compiling T13869B ( T13869b.hs, interpreted )[interactive-session] Ok, one module added. Ok, two modules reloaded. -[1 of 2] Compiling T13869A ( T13869a.hs, interpreted ) -[2 of 2] Compiling T13869B ( T13869b.hs, interpreted ) +[1 of 2] Compiling T13869A ( T13869a.hs, interpreted )[interactive-session] +[2 of 2] Compiling T13869B ( T13869b.hs, interpreted )[interactive-session] Ok, two modules loaded. Ok, one module unadded. ===================================== testsuite/tests/ghci/scripts/T13997.stdout ===================================== @@ -1,8 +1,8 @@ -[1 of 2] Compiling Bug2 ( Bug2.hs, Bug2.o ) -[2 of 2] Compiling Bug ( Bug.hs, Bug.o ) +[1 of 2] Compiling Bug2 ( Bug2.hs, Bug2.o )[main] +[2 of 2] Compiling Bug ( Bug.hs, Bug.o )[interactive-session] Ok, two modules loaded. -[1 of 3] Compiling New ( New.hs, New.o ) -[2 of 3] Compiling Bug2 ( Bug2.hs, Bug2.o ) [Source file changed] -[3 of 3] Compiling Bug ( Bug.hs, Bug.o ) [Bug2 changed] +[1 of 3] Compiling New ( New.hs, New.o )[main] +[2 of 3] Compiling Bug2 ( Bug2.hs, Bug2.o )[main] [Source file changed] +[3 of 3] Compiling Bug ( Bug.hs, Bug.o )[interactive-session] [Bug2 changed] Ok, three modules reloaded. True ===================================== testsuite/tests/ghci/scripts/T17669.stdout ===================================== @@ -1,6 +1,6 @@ -[1 of 1] Compiling T17669 ( T17669.hs, T17669.o ) +[1 of 1] Compiling T17669 ( T17669.hs, T17669.o )[interactive-session] Ok, one module loaded. this -[1 of 1] Compiling T17669 ( T17669.hs, T17669.o ) [Source file changed] +[1 of 1] Compiling T17669 ( T17669.hs, T17669.o )[interactive-session] [Source file changed] Ok, one module reloaded. that ===================================== testsuite/tests/ghci/scripts/T18330.stdout ===================================== @@ -1,9 +1,8 @@ -GHCi, version 9.3.20211019: https://www.haskell.org/ghc/ :? for help -ghci> [1 of 2] Compiling Main ( shell.hs, interpreted ) -[2 of 2] Linking shell +GHCi, version 9.13.20250422: https://www.haskell.org/ghc/ :? for help +ghci> [1 of 2] Compiling Main ( shell.hs, interpreted )[interactive-session] Ok, one module loaded. -ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted ) -Ok, one module loaded. -ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted ) [T18330.extra changed] +ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted )[interactive-session] Ok, one module loaded. +ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted )[interactive-session] [T18330.extra changed] +Ok, one module reloaded. ghci> Leaving GHCi. ===================================== testsuite/tests/ghci/scripts/T1914.stdout ===================================== @@ -1,7 +1,7 @@ -[1 of 2] Compiling T1914B ( T1914B.hs, interpreted ) -[2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) +[1 of 2] Compiling T1914B ( T1914B.hs, interpreted )[main] +[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )[interactive-session] Ok, two modules loaded. -[2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) [Source file changed] +[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )[interactive-session] [Source file changed] Failed, one module reloaded. -[2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) +[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )[interactive-session] Ok, two modules reloaded. ===================================== testsuite/tests/ghci/scripts/T20217.stdout ===================================== @@ -1,5 +1,5 @@ -[1 of 3] Compiling T20217A[boot] ( T20217A.hs-boot, nothing ) -[2 of 3] Compiling T20217A ( T20217A.hs, nothing ) -[3 of 3] Compiling T20217 ( T20217.hs, nothing ) +[1 of 3] Compiling T20217A[boot] ( T20217A.hs-boot, nothing )[main] +[2 of 3] Compiling T20217A ( T20217A.hs, nothing )[main] +[3 of 3] Compiling T20217 ( T20217.hs, nothing )[interactive-session] Ok, three modules loaded. Ok, three modules reloaded. ===================================== testsuite/tests/ghci/scripts/T20587.stdout ===================================== @@ -1,4 +1,4 @@ -[1 of 1] Compiling B +[1 of 1] Compiling B[interactive-session] Ok, one module loaded. -[1 of 1] Compiling B [Source file changed] +[1 of 1] Compiling B[interactive-session] [Source file changed] Ok, one module reloaded. ===================================== testsuite/tests/ghci/scripts/T6105.stdout ===================================== @@ -1,4 +1,4 @@ -[1 of 1] Compiling T6105 ( T6105.hs, interpreted ) +[1 of 1] Compiling T6105 ( T6105.hs, interpreted )[interactive-session] Ok, one module loaded. -[1 of 1] Compiling T6105 ( T6105.hs, interpreted ) +[1 of 1] Compiling T6105 ( T6105.hs, interpreted )[interactive-session] Ok, one module reloaded. ===================================== testsuite/tests/ghci/scripts/T8042.stdout ===================================== @@ -1,9 +1,9 @@ -[1 of 3] Compiling T8042B ( T8042B.hs, T8042B.o ) -[2 of 3] Compiling T8042C ( T8042C.hs, interpreted ) -[3 of 3] Compiling T8042A ( T8042A.hs, interpreted ) +[1 of 3] Compiling T8042B ( T8042B.hs, T8042B.o )[main] +[2 of 3] Compiling T8042C ( T8042C.hs, interpreted )[main] +[3 of 3] Compiling T8042A ( T8042A.hs, interpreted )[interactive-session] Ok, three modules loaded. -[3 of 3] Compiling T8042A ( T8042A.hs, T8042A.o ) [Source file changed] +[3 of 3] Compiling T8042A ( T8042A.hs, T8042A.o )[interactive-session] [Source file changed] Ok, three modules reloaded. -[2 of 3] Compiling T8042C ( T8042C.hs, interpreted ) -[3 of 3] Compiling T8042A ( T8042A.hs, interpreted ) +[2 of 3] Compiling T8042C ( T8042C.hs, interpreted )[main] +[3 of 3] Compiling T8042A ( T8042A.hs, interpreted )[interactive-session] Ok, three modules loaded. ===================================== testsuite/tests/ghci/scripts/T8042recomp.stdout ===================================== @@ -1,6 +1,6 @@ -[1 of 2] Compiling T8042B ( T8042B.hs, T8042B.o ) -[2 of 2] Compiling T8042A ( T8042A.hs, T8042A.o ) +[1 of 2] Compiling T8042B ( T8042B.hs, T8042B.o )[main] +[2 of 2] Compiling T8042A ( T8042A.hs, T8042A.o )[interactive-session] Ok, two modules loaded. -[2 of 2] Compiling T8042A ( T8042A.hs, interpreted ) +[2 of 2] Compiling T8042A ( T8042A.hs, interpreted )[interactive-session] Ok, two modules loaded. Breakpoint 0 activated at T8042A.hs:1:44-56 ===================================== testsuite/tests/ghci/should_run/TopEnvIface.stdout ===================================== @@ -1,5 +1,5 @@ -[1 of 2] Compiling TopEnvIface2 ( TopEnvIface2.hs, interpreted ) -[2 of 2] Compiling TopEnvIface ( TopEnvIface.hs, interpreted ) +[1 of 2] Compiling TopEnvIface2 ( TopEnvIface2.hs, interpreted )[main] +[2 of 2] Compiling TopEnvIface ( TopEnvIface.hs, interpreted )[main] Ok, two modules loaded. "I should be printed twice" Leaving GHCi. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d0a36c84651dee8ff3dd198a167b33… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d0a36c84651dee8ff3dd198a167b33… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25989
by Ben Gamari (＠bgamari) 23 Apr '25

23 Apr '25

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

1 0

[Git][ghc/ghc][wip/splice-imports-2025] 3 commits: downsweep: Move functions to top level and use DownsweepM monad
by Matthew Pickering (＠mpickering) 23 Apr '25

23 Apr '25

Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC Commits: e124b9ef by Matthew Pickering at 2025-04-23T14:42:53+01:00 downsweep: Move functions to top level and use DownsweepM monad This refactoring moves the functions in GHC.Driver.Downsweep to the top-level (rather than a very long where clause), and uses a monad to thread around the relevant configuration options. In the splice improrts patch, I need to use a different entry point into these functions, so I have separated this refactoring into a separate commit. - - - - - a55ce077 by Matthew Pickering at 2025-04-23T15:20:56+01:00 GHCi and tests - - - - - 4b4b4c5a by Matthew Pickering at 2025-04-23T16:35:03+01:00 Test self-edges - - - - - 19 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/Stage.hs - ghc/GHCi/UI.hs - + testsuite/tests/splice-imports/SI30.stdout - + testsuite/tests/splice-imports/SI31.script - + testsuite/tests/splice-imports/SI31.stderr - + testsuite/tests/splice-imports/SI32.script - + testsuite/tests/splice-imports/SI32.stdout - + testsuite/tests/splice-imports/SI33.script - + testsuite/tests/splice-imports/SI33.stdout - + testsuite/tests/splice-imports/SI34.hs - + testsuite/tests/splice-imports/SI34.stderr - + testsuite/tests/splice-imports/SI34M1.hs - + testsuite/tests/splice-imports/SI34M2.hs - + testsuite/tests/splice-imports/SI35.hs - + testsuite/tests/splice-imports/SI35A.hs - testsuite/tests/splice-imports/all.T Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -13,6 +13,7 @@ module GHC.Driver.Downsweep , downsweepThunk , downsweepInstalledModules , downsweepFromRootNodes + , downsweepInteractiveImports , DownsweepMode(..) -- * Summary functions , summariseModule @@ -49,6 +50,9 @@ import GHC.Iface.Load import GHC.Parser.Header import GHC.Rename.Names import GHC.Tc.Utils.Backpack +import GHC.Runtime.Context + +import Language.Haskell.Syntax.ImpExp import GHC.Data.Graph.Directed import GHC.Data.FastString @@ -76,6 +80,8 @@ import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.Map import GHC.Types.PkgQual +import GHC.Types.Basic + import GHC.Unit import GHC.Unit.Env @@ -236,6 +242,46 @@ downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do (GhcDriverMessage <$> unionManyMessages errs) return (mkModuleGraph mg) +-- | Construct a module graph starting from the interactive context. +-- Produces, a thunk, which when forced will perform the downsweep. +-- This graph contains the current interactive module, and its dependencies. + +-- This is a first approximation for this function. +downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph +downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do + let imps = ic_imports (hsc_IC hsc_env) + + let mn = icInteractiveModule ic + let ml = pprPanic "withInteractiveModuleNode" (ppr mn <+> ppr imps) + let key = moduleToMnk mn NotBoot + let node_type = ModuleNodeFixed key ml + + let edges = map mkEdge imps + let env = DownsweepEnv hsc_env DownsweepUseCompile mempty [] + (module_edges, graph, _) <- runDownsweepM env $ loopImports edges M.empty Map.empty + let node = ModuleNode module_edges node_type + + let all_nodes = M.elems graph + let graph = mkModuleGraph (node : all_nodes) + + return graph + + where + -- + mkEdge :: InteractiveImport -> (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) + -- A simple edge to a module from the same home unit + mkEdge (IIModule n) = + let unitId = homeUnitId $ hsc_home_unit hsc_env + in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc n) NotBoot) + -- A complete import statement + mkEdge (IIDecl i) = + let lvl = convImportLevel (ideclLevelSpec i) + wanted_mod = unLoc (ideclName i) + is_boot = ideclSource i + mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i) + unitId = homeUnitId $ hsc_home_unit hsc_env + in (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) + -- | Create a module graph from a list of installed modules. -- This is used by the loader when we need to load modules but there -- isn't already an existing module graph. For example, when loading plugins @@ -298,13 +344,16 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root = do let root_map = mkRootMap root_nodes checkDuplicates root_map - (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map) - let all_deps = loopUnit hsc_env module_deps root_uids + let env = DownsweepEnv hsc_env mode old_summaries excl_mods + (deps', map0) <- runDownsweepM env $ do + (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map) + let all_deps = loopUnit hsc_env module_deps root_uids + let all_instantiations = getHomeUnitInstantiations hsc_env + deps' <- loopInstantiations all_instantiations all_deps + return (deps', map0) - let all_instantiations = getHomeUnitInstantiations hsc_env - let deps' = loopInstantiations all_instantiations all_deps - downsweep_errs = lefts $ concat $ M.elems map0 + let downsweep_errs = lefts $ concat $ M.elems map0 downsweep_nodes = M.elems deps' return (downsweep_errs, downsweep_nodes) @@ -312,14 +361,6 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) - - calcDeps ms = - -- Add a dependency on the HsBoot file if it exists - -- This gets passed to the loopImports function which just ignores it if it - -- can't be found. - [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ - [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ] - -- In a root module, the filename is allowed to diverge from the module -- name, so we have to check that there aren't multiple root files -- defining the same module (otherwise the duplicates will be silently @@ -335,208 +376,231 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2 dup_roots = filterOut isSingleton $ map rights (M.elems root_map) - loopInstantiations :: [(UnitId, InstantiatedUnit)] - -> M.Map NodeKey ModuleGraphNode - -> M.Map NodeKey ModuleGraphNode - loopInstantiations [] done = done - loopInstantiations ((home_uid, iud) :xs) done = - let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env - done' = loopUnit hsc_env' done [instUnitInstanceOf iud] - payload = InstantiationNode home_uid iud - in loopInstantiations xs (M.insert (mkNodeKey payload) payload done') - - where - home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) - - - -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit - loopSummaries :: [ModSummary] - -> (M.Map NodeKey ModuleGraphNode, - DownsweepCache) - -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache) - loopSummaries [] done = return done - loopSummaries (ms:next) (done, summarised) - | Just {} <- M.lookup k done - = loopSummaries next (done, summarised) - -- Didn't work out what the imports mean yet, now do that. - | otherwise = do - (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised - -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. - (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' - loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') - where - k = NodeKey_Module (msKey ms) - - hs_file_for_boot - | HsBootFile <- ms_hsc_src ms - = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) - | otherwise - = Nothing - - loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache) - loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is - - loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache) - loopModuleNodeInfo mod_node_info (done, summarised) = do - case mod_node_info of - ModuleNodeCompile ms -> do - loopSummaries [ms] (done, summarised) - ModuleNodeFixed mod ml -> do - done' <- loopFixedModule mod ml done - return (done', summarised) - - -- NB: loopFixedModule does not take a downsweep cache, because if you - -- ever reach a Fixed node, everything under that also must be fixed. - loopFixedModule :: ModNodeKeyWithUid -> ModLocation - -> M.Map NodeKey ModuleGraphNode - -> IO (M.Map NodeKey ModuleGraphNode) - loopFixedModule key loc done = do - let nk = NodeKey_Module key - case M.lookup nk done of - Just {} -> return done - Nothing -> do - -- MP: TODO, we should just read the dependency info from the interface rather than either - -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) - -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) - read_result <- - -- 1. Check if the interface is already loaded into the EPS by some other - -- part of the compiler. - lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case - Just iface -> return (M.Succeeded iface) - Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) - case read_result of - M.Succeeded iface -> do - -- Computer information about this node - let node_deps = ifaceDeps (mi_deps iface) - edges = map mkFixedEdge node_deps - node = ModuleNode edges (ModuleNodeFixed key loc) - foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps) - -- Ignore any failure, we might try to read a .hi-boot file for - -- example, even if there is not one. - M.Failed {} -> - return done - - loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> IO (M.Map NodeKey ModuleGraphNode) - loopFixedNodeKey _ done (Left key) = do - loopFixedImports [key] done - loopFixedNodeKey home_uid done (Right uid) = do - -- Set active unit so that looking loopUnit finds the correct - -- -package flags in the unit state. - let hsc_env' = hscSetActiveUnitId home_uid hsc_env - return $ loopUnit hsc_env' done [uid] - - mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge - mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) - mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid) - - ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)] - ifaceDeps deps = - [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid) - | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps) - ] ++ - [ Right (tcImportLevel lvl, uid) - | (lvl, uid) <- Set.toList (dep_direct_pkgs deps) - ] - - -- Like loopImports, but we already know exactly which module we are looking for. - loopFixedImports :: [ModNodeKeyWithUid] - -> M.Map NodeKey ModuleGraphNode - -> IO (M.Map NodeKey ModuleGraphNode) - loopFixedImports [] done = pure done - loopFixedImports (key:keys) done = do - let nk = NodeKey_Module key - case M.lookup nk done of - Just {} -> loopFixedImports keys done - Nothing -> do - read_result <- findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) - case read_result of - InstalledFound loc -> do - done' <- loopFixedModule key loc done - loopFixedImports keys done' - _otherwise -> - -- If the finder fails, just keep going, there will be another - -- error later. - loopFixedImports keys done - - downsweepSummarise :: HscEnv - -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary - -> IsBootInterface - -> Located ModuleName - -> PkgQual - -> Maybe (StringBuffer, UTCTime) - -> [ModuleName] - -> IO SummariseResult - downsweepSummarise hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = - case mode of - DownsweepUseCompile -> summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods - DownsweepUseFixed -> summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods - - - -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover - -- a new module by doing this. - loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] - -- Work list: process these modules - -> M.Map NodeKey ModuleGraphNode - -> DownsweepCache - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> IO ([ModuleNodeEdge], - M.Map NodeKey ModuleGraphNode, DownsweepCache) - -- The result is the completed NodeMap - loopImports [] done summarised = return ([], done, summarised) - loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised - | Just summs <- M.lookup cache_key summarised - = case summs of - [Right ms] -> do - let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms)) - (rest, summarised', done') <- loopImports ss done summarised - return (nk: rest, summarised', done') - [Left _err] -> - loopImports ss done summarised - _errs -> do - loopImports ss done summarised - | otherwise - = do - mb_s <- downsweepSummarise hsc_env home_unit old_summaries - is_boot wanted_mod mb_pkg - Nothing excl_mods - case mb_s of - NotThere -> loopImports ss done summarised - External uid -> do - -- Pass an updated hsc_env to loopUnit, as each unit might - -- have a different visible package database. - let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env - let done' = loopUnit hsc_env' done [uid] - (other_deps, done'', summarised') <- loopImports ss done' summarised - return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised') - FoundInstantiation iud -> do - (other_deps, done', summarised') <- loopImports ss done summarised - return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised') - FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) - FoundHome s -> do - (done', summarised') <- - loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised) - (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' - - -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. - return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised) - where - cache_key = (home_uid, mb_pkg, unLoc <$> gwib) - home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) - GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib - wanted_mod = L loc mod - - loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode - loopUnit _ cache [] = cache - loopUnit lcl_hsc_env cache (u:uxs) = do - let nk = (NodeKey_ExternalUnit u) - case Map.lookup nk cache of - Just {} -> loopUnit lcl_hsc_env cache uxs - Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of - Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs - Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u) + +calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] +calcDeps ms = + -- Add a dependency on the HsBoot file if it exists + -- This gets passed to the loopImports function which just ignores it if it + -- can't be found. + [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ + [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ] + + +type DownsweepM a = ReaderT DownsweepEnv IO a +data DownsweepEnv = DownsweepEnv { + downsweep_hsc_env :: HscEnv + , _downsweep_mode :: DownsweepMode + , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary + , _downsweep_excl_mods :: [ModuleName] +} + +runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a +runDownsweepM env act = runReaderT act env + + +loopInstantiations :: [(UnitId, InstantiatedUnit)] + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopInstantiations [] done = pure done +loopInstantiations ((home_uid, iud) :xs) done = do + hsc_env <- asks downsweep_hsc_env + let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + done' = loopUnit hsc_env' done [instUnitInstanceOf iud] + payload = InstantiationNode home_uid iud + loopInstantiations xs (M.insert (mkNodeKey payload) payload done') + + +-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit +loopSummaries :: [ModSummary] + -> (M.Map NodeKey ModuleGraphNode, + DownsweepCache) + -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache) +loopSummaries [] done = pure done +loopSummaries (ms:next) (done, summarised) + | Just {} <- M.lookup k done + = loopSummaries next (done, summarised) + -- Didn't work out what the imports mean yet, now do that. + | otherwise = do + (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised + -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. + (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' + loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') + where + k = NodeKey_Module (msKey ms) + + hs_file_for_boot + | HsBootFile <- ms_hsc_src ms + = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) + | otherwise + = Nothing + +loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) +loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is + +loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) +loopModuleNodeInfo mod_node_info (done, summarised) = do + case mod_node_info of + ModuleNodeCompile ms -> do + loopSummaries [ms] (done, summarised) + ModuleNodeFixed mod ml -> do + done' <- loopFixedModule mod ml done + return (done', summarised) + +-- NB: loopFixedModule does not take a downsweep cache, because if you +-- ever reach a Fixed node, everything under that also must be fixed. +loopFixedModule :: ModNodeKeyWithUid -> ModLocation + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedModule key loc done = do + let nk = NodeKey_Module key + hsc_env <- asks downsweep_hsc_env + case M.lookup nk done of + Just {} -> return done + Nothing -> do + -- MP: TODO, we should just read the dependency info from the interface rather than either + -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) + -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) + read_result <- liftIO $ + -- 1. Check if the interface is already loaded into the EPS by some other + -- part of the compiler. + lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case + Just iface -> return (M.Succeeded iface) + Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) + case read_result of + M.Succeeded iface -> do + -- Computer information about this node + let node_deps = ifaceDeps (mi_deps iface) + edges = map mkFixedEdge node_deps + node = ModuleNode edges (ModuleNodeFixed key loc) + foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps) + -- Ignore any failure, we might try to read a .hi-boot file for + -- example, even if there is not one. + M.Failed {} -> + return done + +loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedNodeKey _ done (Left key) = do + loopFixedImports [key] done +loopFixedNodeKey home_uid done (Right uid) = do + -- Set active unit so that looking loopUnit finds the correct + -- -package flags in the unit state. + hsc_env <- asks downsweep_hsc_env + let hsc_env' = hscSetActiveUnitId home_uid hsc_env + return $ loopUnit hsc_env' done [uid] + +mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge +mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) +mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid) + +ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)] +ifaceDeps deps = + [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid) + | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps) + ] ++ + [ Right (tcImportLevel lvl, uid) + | (lvl, uid) <- Set.toList (dep_direct_pkgs deps) + ] + +-- Like loopImports, but we already know exactly which module we are looking for. +loopFixedImports :: [ModNodeKeyWithUid] + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedImports [] done = pure done +loopFixedImports (key:keys) done = do + let nk = NodeKey_Module key + hsc_env <- asks downsweep_hsc_env + case M.lookup nk done of + Just {} -> loopFixedImports keys done + Nothing -> do + read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) + case read_result of + InstalledFound loc -> do + done' <- loopFixedModule key loc done + loopFixedImports keys done' + _otherwise -> + -- If the finder fails, just keep going, there will be another + -- error later. + loopFixedImports keys done + +downsweepSummarise :: HomeUnit + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> DownsweepM SummariseResult +downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do + DownsweepEnv hsc_env mode old_summaries excl_mods <- ask + case mode of + DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods + DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + + +-- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover +-- a new module by doing this. +loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + -- Work list: process these modules + -> M.Map NodeKey ModuleGraphNode + -> DownsweepCache + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> DownsweepM ([ModuleNodeEdge], + M.Map NodeKey ModuleGraphNode, DownsweepCache) + -- The result is the completed NodeMap +loopImports [] done summarised = return ([], done, summarised) +loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised + | Just summs <- M.lookup cache_key summarised + = case summs of + [Right ms] -> do + let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms)) + (rest, summarised', done') <- loopImports ss done summarised + return (nk: rest, summarised', done') + [Left _err] -> + loopImports ss done summarised + _errs -> do + loopImports ss done summarised + | otherwise + = do + hsc_env <- asks downsweep_hsc_env + let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + mb_s <- downsweepSummarise home_unit + is_boot wanted_mod mb_pkg + Nothing + case mb_s of + NotThere -> loopImports ss done summarised + External uid -> do + -- Pass an updated hsc_env to loopUnit, as each unit might + -- have a different visible package database. + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + let done' = loopUnit hsc_env' done [uid] + (other_deps, done'', summarised') <- loopImports ss done' summarised + return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised') + FoundInstantiation iud -> do + (other_deps, done', summarised') <- loopImports ss done summarised + return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised') + FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) + FoundHome s -> do + (done', summarised') <- + loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised) + (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' + + -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. + return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised) + where + cache_key = (home_uid, mb_pkg, unLoc <$> gwib) + GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib + wanted_mod = L loc mod + +loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode +loopUnit _ cache [] = cache +loopUnit lcl_hsc_env cache (u:uxs) = do + let nk = (NodeKey_ExternalUnit u) + case Map.lookup nk cache of + Just {} -> loopUnit lcl_hsc_env cache uxs + Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of + Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs + Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u) multiRootsErr :: [ModuleNodeInfo] -> IO () multiRootsErr [] = panic "multiRootsErr" ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -164,6 +164,7 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Deps +import GHC.Driver.Downsweep import GHC.Data.FastString import GHC.Data.Maybe @@ -2077,12 +2078,25 @@ was added for External Core which faced a similar issue. ********************************************************* -} +-- This function is essentially a single-level downsweep +-- for an interactive module. There is no source file, so we create a fixed node. +withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a +withInteractiveModuleNode hsc_env thing_inside = do + mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env) + updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside + + + + + + runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ + withInteractiveModuleNode hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -101,6 +101,9 @@ module GHC.Unit.Module.Graph -- time it's called. , filterToposortToModules , moduleGraphNodesZero + , StageSummaryNode + , stageSummaryNodeSummary + , stageSummaryNodeKey , mkStageDeps -- * Keys into the 'ModuleGraph' @@ -930,6 +933,9 @@ stageSummaryNodeSummary = node_payload -- * If NoImplicitStagePersistence then Quote/Splice/Normal imports offset the required stage -- * If ImplicitStagePersistence and TemplateHaskell then imported module are needed at all stages. -- * Otherwise, an imported module is just needed at the normal stage. +-- +-- * A module using TemplateHaskellQuotes required at C stage is also required at R +-- stage. moduleGraphNodesStages :: [ModuleGraphNode] -> (Graph StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode) @@ -945,7 +951,7 @@ moduleGraphNodesStages summaries = normal_case :: (ModuleGraphNode, ModuleStage) -> StageSummaryNode normal_case ((m@(ModuleNode nks ms), s)) = DigraphNode ((mkNodeKey m, s)) key $ out_edge_keys $ - concatMap (classifyDeps ms s) nks + selfEdges ms s (mkNodeKey m) ++ concatMap (classifyDeps ms s) nks normal_case (m, s) = DigraphNode (mkNodeKey m, s) key (out_edge_keys . map (, s) $ mgNodeDependencies False m) @@ -955,6 +961,16 @@ moduleGraphNodesStages summaries = isTemplateHaskellQuotesMS :: ModSummary -> Bool isTemplateHaskellQuotesMS ms = xopt LangExt.TemplateHaskellQuotes (ms_hspp_opts ms) + -- Accounting for persistence within a module. + -- If a module is required @ C and it persists an idenfifier, it's also required + -- at R. + selfEdges (ModuleNodeCompile ms) s self_key + | not (isExplicitStageMS ms) + && (isTemplateHaskellQuotesMS ms + || isTemplateHaskellOrQQNonBoot ms) + = [(self_key, s') | s' <- onlyFutureStages s] + selfEdges _ _ _ = [] + -- Case 1. No implicit stage persistnce is enabled classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge il k) | isExplicitStageMS ms = case il of @@ -966,7 +982,7 @@ moduleGraphNodesStages summaries = | not (isExplicitStageMS ms) , not (isTemplateHaskellOrQQNonBoot ms) , isTemplateHaskellQuotesMS ms - = [(k, s') | s' <- futureStages s] + = [(k, s') | s' <- nowAndFutureStages s] -- Case 2b. Template haskell is enabled, with implicit stage persistence classifyDeps (ModuleNodeCompile ms) _ (ModuleNodeEdge _ k) | isTemplateHaskellOrQQNonBoot ms @@ -977,7 +993,7 @@ moduleGraphNodesStages summaries = numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)] - numbered_summaries = zip (([(s, l) | s <- summaries, l <- [CompileStage, RunStage]])) [0..] + numbered_summaries = zip (([(s, l) | s <- summaries, l <- allStages])) [0..] lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode lookup_node key = Map.lookup key node_map ===================================== compiler/GHC/Unit/Module/Stage.hs ===================================== @@ -1,6 +1,7 @@ module GHC.Unit.Module.Stage ( ModuleStage(..) , allStages - , futureStages + , nowAndFutureStages + , onlyFutureStages , minStage , maxStage , zeroStage @@ -56,8 +57,12 @@ data ModuleStage = CompileStage | RunStage deriving (Eq, Ord, Enum, Bounded) allStages :: [ModuleStage] allStages = [minBound .. maxBound] -futureStages :: ModuleStage -> [ModuleStage] -futureStages cur_st = [cur_st .. ] +nowAndFutureStages :: ModuleStage -> [ModuleStage] +nowAndFutureStages cur_st = [cur_st .. ] + +onlyFutureStages :: ModuleStage -> [ModuleStage] +onlyFutureStages cur_st | cur_st == maxBound = [] +onlyFutureStages cur_st = [succ cur_st .. ] minStage :: ModuleStage minStage = minBound ===================================== ghc/GHCi/UI.hs ===================================== @@ -2928,6 +2928,7 @@ iiSubsumes (IIModule m1) (IIModule m2) = m1==m2 iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude = unLoc (ideclName d1) == unLoc (ideclName d2) && ideclAs d1 == ideclAs d2 + && convImportLevel (ideclLevelSpec d1) == convImportLevel (ideclLevelSpec d2) && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2)) && (ideclImportList d1 `hidingSubsumes` ideclImportList d2) where ===================================== testsuite/tests/splice-imports/SI30.stdout ===================================== @@ -0,0 +1 @@ +2 ===================================== testsuite/tests/splice-imports/SI31.script ===================================== @@ -0,0 +1,2 @@ +-- Failure, since explicit level imports is on +$(id [| () |]) \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI31.stderr ===================================== @@ -0,0 +1,7 @@ +<interactive>:2:3: error: [GHC-28914] + • Level error: ‘id’ is bound at level 0 but used at level -1 + Hint: quoting [| id |] or an enclosing expression + would allow the quotation to be used at an earlier level + From imports {imported from ‘Prelude’} + • In the untyped splice: $(id [| () |]) + ===================================== testsuite/tests/splice-imports/SI32.script ===================================== @@ -0,0 +1,5 @@ +-- Success case with explicit level imports +import Language.Haskell.TH +import splice Data.Function (id) + +$(id [| () |]) \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI32.stdout ===================================== @@ -0,0 +1 @@ +() ===================================== testsuite/tests/splice-imports/SI33.script ===================================== @@ -0,0 +1,8 @@ +-- Test using both normal and splice level imports with Template Haskell +import Language.Haskell.TH +-- Using two imports here tests the iiSubsumes function +import splice Data.Function (id) +import Data.Function (id) + +-- Use the splice-level 'id' in the splice and normal-level 'on' in the quote +$(id [| id () |]) \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI33.stdout ===================================== @@ -0,0 +1 @@ +() ===================================== testsuite/tests/splice-imports/SI34.hs ===================================== @@ -0,0 +1,11 @@ +module SI34 where + +-- Compiling SI34 @ R, requires SI34M2 @ R, which requires SI34M1 @ R, +-- but NOT SI34M1 @ C or SI34M2 @ C due to ImplicitStagePersistence + TemplateHaskellQuotes +import SI34M2 + +-- Uses the MkT constructor indirectly through SI34M2.makeMkT +foo = makeMkT 42 + +-- Uses the wrapper type from SI34M2 +bar = wrapT (makeMkT 100) \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI34.stderr ===================================== @@ -0,0 +1,3 @@ +[1 of 3] Compiling SI34M1 ( SI34M1.hs, nothing ) +[2 of 3] Compiling SI34M2 ( SI34M2.hs, nothing ) +[3 of 3] Compiling SI34 ( SI34.hs, nothing ) ===================================== testsuite/tests/splice-imports/SI34M1.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE ImplicitStagePersistence #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module SI34M1 where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data T = MkT Int + deriving Show + +instance Lift T where + lift (MkT n) = [| MkT $(lift n) |] + liftTyped (MkT n) = [|| MkT $$(liftTyped n) ||] ===================================== testsuite/tests/splice-imports/SI34M2.hs ===================================== @@ -0,0 +1,28 @@ +{-# LANGUAGE ImplicitStagePersistence #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module SI34M2 ( + makeMkT, + TWrapper(..), + wrapT +) where + +import SI34M1 +import Language.Haskell.TH.Syntax + +-- A wrapper for T +data TWrapper = WrapT T + deriving Show + +-- Create a MkT with the given Int +makeMkT :: Int -> T +makeMkT = MkT + +-- Wrap a T in a TWrapper +wrapT :: T -> TWrapper +wrapT = WrapT + +-- Quote functions for TWrapper +instance Lift TWrapper where + lift (WrapT t) = [| WrapT $(lift t) |] + liftTyped (WrapT t) = [|| WrapT $$(liftTyped t) ||] ===================================== testsuite/tests/splice-imports/SI35.hs ===================================== @@ -0,0 +1,79 @@ +{-# LANGUAGE RecordWildCards #-} +module Main where + +import GHC +import GHC.Driver.Session +import GHC.Driver.Monad +import GHC.Driver.Make (load', summariseFile) +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary +import GHC.Unit.Types +import GHC.Unit.Module.ModIface +import GHC.Unit.Module +import GHC.Unit.Module.ModNodeKey +import GHC.Types.SourceFile +import System.Environment +import Control.Monad (void, when) +import Data.Maybe (fromJust) +import Control.Exception (ExceptionWithContext(..), SomeException) +import Control.Monad.Catch (handle, throwM) +import Control.Exception.Context +import GHC.Utils.Outputable +import GHC.Unit.Home +import GHC.Driver.Env +import Data.List (sort) +import GHC.Driver.MakeFile +import GHC.Data.Maybe +import GHC.Unit.Module.Stage +import GHC.Data.Graph.Directed.Reachability +import GHC.Utils.Trace +import GHC.Unit.Module.Graph + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ handle (\(ExceptionWithContext c e :: ExceptionWithContext SomeException) -> + liftIO $ putStrLn (displayExceptionContext c) >> print e >> throwM e) $ do + + -- Set up session + dflags <- getSessionDynFlags + setSessionDynFlags dflags + hsc_env <- getSession + setSession $ hscSetActiveUnitId mainUnitId hsc_env + + -- Get ModSummary for our test module + msA <- getModSummaryFromTarget "SI35A.hs" + + -- Define NodeKey + let keyA = NodeKey_Module (msKey msA) + edgeA = mkNormalEdge keyA + + -- Define ModuleNodeInfo + let infoA_compile = ModuleNodeCompile msA + + -- Define the complete node + let nodeA_compile = ModuleNode [] infoA_compile + + -- This test checks that a module required at compile stage invokes a + -- depedency on the runstage of itself when using TemplateHaskellQuotes. + + -- This is hard to test with a normal compiler invocation as GHC does not + -- not distinguish very easily these two stages. + let (ri, to_node) = mkStageDeps [nodeA_compile] + let reachable = allReachable ri (expectJust $ to_node (keyA, CompileStage)) + let reachable_nodes = map stageSummaryNodeSummary reachable + + if (keyA, RunStage) `elem` reachable_nodes + then return () + else do + liftIO $ putStrLn "Test failed -- (keyA, RunStage) not reachable" + pprTraceM "reachable_nodes" (ppr reachable_nodes) + pprTraceM "reachable" (ppr (reachabilityIndexMembers ri)) + + where + -- Helper to get ModSummary from a target file + getModSummaryFromTarget :: FilePath -> Ghc ModSummary + getModSummaryFromTarget file = do + hsc_env <- getSession + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + return ms \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI35A.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module SI35A where + +-- Define a type for use in Template Haskell +data T = MkT Int + +-- Helper function to construct a T +mkT :: Int -> T +mkT = MkT + +-- A function that creates a quoted expression using T +quotedT :: Int -> Q Exp +quotedT n = [| mkT n |] + +-- Another quoted expression function +quotedAdd :: Q Exp +quotedAdd = [| \x y -> x + y :: Int |] + +-- Show instance +instance Show T where + show (MkT n) = "MkT " ++ show n \ No newline at end of file ===================================== testsuite/tests/splice-imports/all.T ===================================== @@ -36,3 +36,12 @@ test('SI27', normal, compile_fail, ['']) test('SI28', normal, compile_fail, ['']) test('SI29', normal, compile_fail, ['']) test('SI30', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports")], ghci_script, ['SI30.script']) +test('SI31', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI31.script']) +test('SI32', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI32.script']) +test('SI33', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI33.script']) +test('SI34', [extra_files(["SI34M1.hs", "SI34M2.hs"])], multimod_compile, ['SI34', '-fno-code']) +test('SI35', + [extra_run_opts(f'"{config.libdir}"'), + extra_files(['SI35A.hs'])], + compile_and_run, + ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e44ea99aafb6f70c4618bfb3c2c565… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e44ea99aafb6f70c4618bfb3c2c565… You're receiving this email because of your account on gitlab.haskell.org.

1 0