- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/mangoiv/hadrian-uncompressed-tar] hadrian: allow building binary dist tar without compression
by Magnus (＠MangoIV) 15 Jul '26

15 Jul '26

Magnus pushed to branch wip/mangoiv/hadrian-uncompressed-tar at Glasgow Haskell Compiler / GHC Commits: e189126d by mangoiv at 2026-07-15T15:09:36+02:00 hadrian: allow building binary dist tar without compression - - - - - 1 changed file: - hadrian/src/Rules/BinaryDist.hs Changes: ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -365,16 +365,17 @@ bindistRules = do -- Finally, we create the archive <root>/bindist/ghc-X.Y.Z-platform.tar.xz tarPath <- builderPath (Tar Create) - cmd [Cwd $ root -/- bindist_folder] tarPath - [ "-c", compressorTarFlag compressor, "-f" - , ghcVersionPretty <.> "tar" <.> compressorExtension compressor - , ghcVersionPretty ] + cmd [Cwd $ root -/- bindist_folder] tarPath $ + [ "-c" + , "-f" , compressorExtension compressor $ ghcVersionPretty <.> "tar" + , ghcVersionPretty ] <> compressorTarFlag compressor forM_ [("binary", buildBinDist), ("reloc-binary", buildBinDistReloc)] $ \(name, mk_bindist) -> do phony (name <> "-dist") $ mk_bindist Xz phony (name <> "-dist-gzip") $ mk_bindist Gzip phony (name <> "-dist-bzip2") $ mk_bindist Bzip2 phony (name <> "-dist-xz") $ mk_bindist Xz + phony (name <> "-dist-uncompressed") $ mk_bindist NoCompressor phony "binary-dist-cross" $ buildBinDistX "binary-dist-dir-cross" "bindist" Xz phony "binary-dist-stage3" $ buildBinDistX "binary-dist-dir-stage3" "bindist" Xz @@ -430,7 +431,7 @@ bindistRules = do fixup f | f `elem` ["INSTALL", "README"] = "distrib" -/- f | otherwise = f -data Compressor = Gzip | Bzip2 | Xz +data Compressor = Gzip | Bzip2 | Xz | NoCompressor deriving (Eq, Ord, Show) @@ -448,16 +449,18 @@ generateBuildMk BindistConfig{..} = do a =. b = a ++ " = " ++ b -- | Flag to pass to tar to use the given 'Compressor'. -compressorTarFlag :: Compressor -> String -compressorTarFlag Gzip = "--gzip" -compressorTarFlag Xz = "--xz" -compressorTarFlag Bzip2 = "--bzip" +compressorTarFlag :: Compressor -> [String] +compressorTarFlag Gzip = ["--gzip"] +compressorTarFlag Xz = ["--xz" ] +compressorTarFlag Bzip2 = ["--bzip"] +compressorTarFlag NoCompressor = [] -- | File extension to use for archives compressed with the given 'Compressor'. -compressorExtension :: Compressor -> String -compressorExtension Gzip = "gz" -compressorExtension Xz = "xz" -compressorExtension Bzip2 = "bz2" +compressorExtension :: Compressor -> String -> String +compressorExtension Gzip p = p <.> "gz" +compressorExtension Xz p = p <.> "xz" +compressorExtension Bzip2 p = p <.> "bz2" +compressorExtension NoCompressor p = p -- | A list of files that allow us to support a simple -- @./configure [...] && make install@ workflow. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e189126dd7e849947adf38144d3e25d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e189126dd7e849947adf38144d3e25d… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/improve-linker-discovery] configure: implement a saner linker discovery algorithm in dist/configure
by Magnus (＠MangoIV) 15 Jul '26

15 Jul '26

Magnus pushed to branch wip/mangoiv/improve-linker-discovery at Glasgow Haskell Compiler / GHC Commits: 9fde49e8 by mangoiv at 2026-07-15T15:04:37+02:00 configure: implement a saner linker discovery algorithm in dist/configure - - - - - 3 changed files: - distrib/configure.ac.in - + m4/bindist_determine_linker.m4 - m4/find_merge_objects.m4 Changes: ===================================== distrib/configure.ac.in ===================================== @@ -175,7 +175,11 @@ AC_SUBST([CmmCPPSupportsG0]) dnl ** Which ld to use? dnl -------------------------------------------------------------- -FIND_LD([$target],[GccUseLdOpt]) +dnl currently if you pass $LD=foo, merge objs command will be set to $(which foo) +dnl which is not required by GHC and also wrong. +BINDIST_DETERMINE_LINKER([$target],[GccUseLdOpt]) +dnl at this point, we should have set LD in all cases, so FIND_MERGE_OBJECTS command can +dnl go off and do it's thing FIND_MERGE_OBJECTS() CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 $GccUseLdOpt" CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 $GccUseLdOpt" ===================================== m4/bindist_determine_linker.m4 ===================================== @@ -0,0 +1,134 @@ +# BINDIST_DETERMINE_LINKER +# ------------------------ +# +# This is used to determine the linker within the bindists configure +# +# Notes: +# - usually, linking works by invoking $CC +# - objects are merged using $LD directly +# - $LD is a configure variable and is meaningless to $CC +# - gcc only knows linker *flavours*, it cannot use paths +# which means that the linker path should not be an absolute path +# - clang konws --ld-path which means that it can be passed that +# flag and also merge objs can be an absolute path +# +# Algorithm: +# if $LD is set +# then if $CC accepts --ld-path=$(which $LD) +# then set --ld-path=$(which $LD), MergeObjsCommand=$(which $LD) +# else if $CC accepts --fuse-ld=$LD ($LD is a linker flavour, not an absolute path) +# then set -fuse-ld=$LD, MergeObjsCommand=$LD (not $(which ld)) +# else Reject with +# "$LD is not compatible with $CC you chose. This means that $LD is either +# an unsupported linker flavour or your $CC does not support absolute linker +# paths" +# else if --disable-ld-override is set or $target is macos +# then if $CC accepts --ld-path=$(which ld) +# then set --ld-path=$(which ld), set MergeObjsCommand=$(which ld) +# else set *no* flag (equivalent to --fuse-ld=ld, if you will), set MergeObjsCommand=ld +# else if $CC accepts --ld-path=$(which ld.lld) +# then set --ld-path=$(which ld.lld), MergeObjsCommand=$(which ld.lld) +# else if $CC accepts -fuse-ld=lld +# then set -fuse-ld=lld, MergeObjsCommand=ld.lld +# else set *no* flag (equivalent to --fuse-ld=ld), set MergeObjsCommand=ld +# +# $1 = the platform +# $2 = the variable to set with GHC options to configure gcc to use the chosen linker +# +AC_DEFUN([BINDIST_DETERMINE_LINKER],[ + AC_ARG_ENABLE(ld-override, + [AS_HELP_STRING([--disable-ld-override], + [Prevent GHC from overriding the default linker used by gcc. If ld-override is enabled GHC will try to tell gcc to use whichever linker is selected by the LD environment variable. [default=override enabled]])], + [], + [enable_ld_override=yes]) + + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_TARGET]) + + check_ld_path() { + AC_MSG_CHECKING([whether C compiler supports --ld-path=[$]1]) + ld_path="[$]1" + echo 'int main(void) { return 0; }' > conftest.c + if $CC -o conftest.o "--ld-path=$ld_path" $LDFLAGS conftest.c > /dev/null 2>&1 + then + AC_MSG_RESULT([yes]) + ld_path_ok=yes + else + AC_MSG_RESULT([no]) + ld_path_ok=no + fi + rm -f conftest.c conftest.o + } + + check_fuse_ld() { + AC_MSG_CHECKING([whether C compiler supports -fuse-ld=[$]1]) + ld="[$]1" + echo 'int main(void) {return 0;}' > conftest.c + if $CC -o conftest.o -fuse-ld=[$]1 $LDFLAGS conftest.c > /dev/null 2>&1 + then + AC_MSG_RESULT([yes]) + fuse_ld_ok=yes + else + AC_MSG_RESULT([no]) + fuse_ld_ok=no + fi + rm -f conftest.c conftest.o + } + + try_set_linker_to() { + AC_MSG_CHECKING([whether linker can be set to [$]1]) + tmp_ld=[$]1 + abs_path=`command -v "$tmp_ld" 2>/dev/null` # get absolute path of $tmp_ld if it isn't already one + ld_path_ok="no" + if test "z$abs_path" != "z" && check_ld_path "$abs_path" && test "x$ld_path_ok" = "xyes"; + then $2="--ld-path=$abs_path" + AC_CHECK_TARGET_TOOL([LD], [$abs_path]) + linker_set_successfully=yes + else # --ld-path does not work or $LD cannot be resolved to an absolute path + fuse_ld_ok=no + if check_fuse_ld "$tmp_ld" && test "x$fuse_ld_ok" = "xyes"; + then $2="-fuse-ld=$tmp_ld" + AC_CHECK_TARGET_TOOL([LD], [$tmp_ld]) + linker_set_successfully=yes + else AC_MSG_WARN(["$tmp_ld could not be set via either '--ld-path' or '-fuse-ld"]) + linker_set_successfully=no + fi + fi + } + + # we are lenient when $LD=ld and just act as if $LD wasn't set and + # enable-ld-override is off + if test "z$LD" != "z" && test "z$LD" != "zld"; + then linker_set_successfully=no + try_set_linker_to "$LD" + if test "z$linker_set_successfully" != "zyes"; + then AC_MSG_FAILURE([ $tmp_ld is an invalid linker. If your C compiler accepts the '--ld-path' flag, + \$LD can be either of an executable name that is in \$PATH *or* a path to an executable. + If your C compiler only supports the '--fuse-ld' flag, \$LD can only be one of the linker flavours supported + by it. Mind that if your C compiler supports '--ld-path', 'configure' will always prefer using an absolute path + to your linker as that is less error-prone.]) + fi + + else # $LD is not set -- we will do the ld-override non-sense + if test "x$enable_ld_override" = "xyes" && test "z$LD" != "zld" && case "$1" in + *-darwin) false ;; # don't do the ld override thing on macos + *) true ;; + esac; + then + AC_MSG_NOTICE(["enable ld override was set and no more specific linker was chosen by setting \$LD, trying to find best possible linker"]) + try_set_linker_to "lld" + if test "z$linker_set_successfully" != "zyes"; + then # ... bail out, just use ld in path + $2="" + AC_CHECK_TARGET_TOOL([LD], [ld]) + fi + else # ld override is not set and $LD not set either + $2="" + AC_CHECK_TARGET_TOOL([LD], [ld]) + fi + fi + + AC_MSG_NOTICE([linker discovery set $2 set to $$2]) + + CHECK_LD_COPY_BUG([$1]) +]) ===================================== m4/find_merge_objects.m4 ===================================== @@ -22,7 +22,6 @@ AC_DEFUN([CHECK_MERGE_OBJECTS],[ ]) AC_DEFUN([FIND_MERGE_OBJECTS],[ - AC_REQUIRE([FIND_LD]) if test -z ${MergeObjsCmd+x}; then AC_MSG_NOTICE([Setting cmd]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9fde49e8d1bc73697d9cf271bb19b1b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9fde49e8d1bc73697d9cf271bb19b1b… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/mangoiv/hadrian-uncompressed-tar
by Magnus (＠MangoIV) 15 Jul '26

15 Jul '26

Magnus pushed new branch wip/mangoiv/hadrian-uncompressed-tar at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/mangoiv/hadrian-uncompressed-… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/improve-linker-discovery] 2 commits: configure: implement a saner linker discovery algorithm in dist/configure
by Magnus (＠MangoIV) 15 Jul '26

15 Jul '26

Magnus pushed to branch wip/mangoiv/improve-linker-discovery at Glasgow Haskell Compiler / GHC Commits: e55e16b2 by mangoiv at 2026-07-15T13:39:12+02:00 configure: implement a saner linker discovery algorithm in dist/configure - - - - - bd3bfcf2 by mangoiv at 2026-07-15T14:59:05+02:00 hadrian: allow building binary dist tar without compression - - - - - 4 changed files: - distrib/configure.ac.in - hadrian/src/Rules/BinaryDist.hs - + m4/bindist_determine_linker.m4 - m4/find_merge_objects.m4 Changes: ===================================== distrib/configure.ac.in ===================================== @@ -175,7 +175,11 @@ AC_SUBST([CmmCPPSupportsG0]) dnl ** Which ld to use? dnl -------------------------------------------------------------- -FIND_LD([$target],[GccUseLdOpt]) +dnl currently if you pass $LD=foo, merge objs command will be set to $(which foo) +dnl which is not required by GHC and also wrong. +BINDIST_DETERMINE_LINKER([$target],[GccUseLdOpt]) +dnl at this point, we should have set LD in all cases, so FIND_MERGE_OBJECTS command can +dnl go off and do it's thing FIND_MERGE_OBJECTS() CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 $GccUseLdOpt" CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 $GccUseLdOpt" ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -365,16 +365,17 @@ bindistRules = do -- Finally, we create the archive <root>/bindist/ghc-X.Y.Z-platform.tar.xz tarPath <- builderPath (Tar Create) - cmd [Cwd $ root -/- bindist_folder] tarPath - [ "-c", compressorTarFlag compressor, "-f" - , ghcVersionPretty <.> "tar" <.> compressorExtension compressor - , ghcVersionPretty ] + cmd [Cwd $ root -/- bindist_folder] tarPath $ + [ "-c" + , "-f" , compressorExtension compressor $ ghcVersionPretty <.> "tar" + , ghcVersionPretty ] <> compressorTarFlag compressor forM_ [("binary", buildBinDist), ("reloc-binary", buildBinDistReloc)] $ \(name, mk_bindist) -> do phony (name <> "-dist") $ mk_bindist Xz phony (name <> "-dist-gzip") $ mk_bindist Gzip phony (name <> "-dist-bzip2") $ mk_bindist Bzip2 phony (name <> "-dist-xz") $ mk_bindist Xz + phony (name <> "-dist-uncompressed") $ mk_bindist NoCompressor phony "binary-dist-cross" $ buildBinDistX "binary-dist-dir-cross" "bindist" Xz phony "binary-dist-stage3" $ buildBinDistX "binary-dist-dir-stage3" "bindist" Xz @@ -430,7 +431,7 @@ bindistRules = do fixup f | f `elem` ["INSTALL", "README"] = "distrib" -/- f | otherwise = f -data Compressor = Gzip | Bzip2 | Xz +data Compressor = Gzip | Bzip2 | Xz | NoCompressor deriving (Eq, Ord, Show) @@ -448,16 +449,18 @@ generateBuildMk BindistConfig{..} = do a =. b = a ++ " = " ++ b -- | Flag to pass to tar to use the given 'Compressor'. -compressorTarFlag :: Compressor -> String -compressorTarFlag Gzip = "--gzip" -compressorTarFlag Xz = "--xz" -compressorTarFlag Bzip2 = "--bzip" +compressorTarFlag :: Compressor -> [String] +compressorTarFlag Gzip = ["--gzip"] +compressorTarFlag Xz = ["--xz" ] +compressorTarFlag Bzip2 = ["--bzip"] +compressorTarFlag NoCompressor = [] -- | File extension to use for archives compressed with the given 'Compressor'. -compressorExtension :: Compressor -> String -compressorExtension Gzip = "gz" -compressorExtension Xz = "xz" -compressorExtension Bzip2 = "bz2" +compressorExtension :: Compressor -> String -> String +compressorExtension Gzip p = p <.> "gz" +compressorExtension Xz p = p <.> "xz" +compressorExtension Bzip2 p = p <.> "bz2" +compressorExtension NoCompressor p = p -- | A list of files that allow us to support a simple -- @./configure [...] && make install@ workflow. ===================================== m4/bindist_determine_linker.m4 ===================================== @@ -0,0 +1,134 @@ +# BINDIST_DETERMINE_LINKER +# ------------------------ +# +# This is used to determine the linker within the bindists configure +# +# Notes: +# - usually, linking works by invoking $CC +# - objects are merged using $LD directly +# - $LD is a configure variable and is meaningless to $CC +# - gcc only knows linker *flavours*, it cannot use paths +# which means that the linker path should not be an absolute path +# - clang konws --ld-path which means that it can be passed that +# flag and also merge objs can be an absolute path +# +# Algorithm: +# if $LD is set +# then if $CC accepts --ld-path=$(which $LD) +# then set --ld-path=$(which $LD), MergeObjsCommand=$(which $LD) +# else if $CC accepts --fuse-ld=$LD ($LD is a linker flavour, not an absolute path) +# then set -fuse-ld=$LD, MergeObjsCommand=$LD (not $(which ld)) +# else Reject with +# "$LD is not compatible with $CC you chose. This means that $LD is either +# an unsupported linker flavour or your $CC does not support absolute linker +# paths" +# else if --disable-ld-override is set or $target is macos +# then if $CC accepts --ld-path=$(which ld) +# then set --ld-path=$(which ld), set MergeObjsCommand=$(which ld) +# else set *no* flag (equivalent to --fuse-ld=ld, if you will), set MergeObjsCommand=ld +# else if $CC accepts --ld-path=$(which ld.lld) +# then set --ld-path=$(which ld.lld), MergeObjsCommand=$(which ld.lld) +# else if $CC accepts -fuse-ld=lld +# then set -fuse-ld=lld, MergeObjsCommand=ld.lld +# else set *no* flag (equivalent to --fuse-ld=ld), set MergeObjsCommand=ld +# +# $1 = the platform +# $2 = the variable to set with GHC options to configure gcc to use the chosen linker +# +AC_DEFUN([BINDIST_DETERMINE_LINKER],[ + AC_ARG_ENABLE(ld-override, + [AS_HELP_STRING([--disable-ld-override], + [Prevent GHC from overriding the default linker used by gcc. If ld-override is enabled GHC will try to tell gcc to use whichever linker is selected by the LD environment variable. [default=override enabled]])], + [], + [enable_ld_override=yes]) + + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_TARGET]) + + check_ld_path() { + AC_MSG_CHECKING([whether C compiler supports --ld-path=[$]1]) + ld_path="[$]1" + echo 'int main(void) { return 0; }' > conftest.c + if $CC -o conftest.o "--ld-path=$ld_path" $LDFLAGS conftest.c > /dev/null 2>&1 + then + AC_MSG_RESULT([yes]) + ld_path_ok=yes + else + AC_MSG_RESULT([no]) + ld_path_ok=no + fi + rm -f conftest.c conftest.o + } + + check_fuse_ld() { + AC_MSG_CHECKING([whether C compiler supports -fuse-ld=[$]1]) + ld="[$]1" + echo 'int main(void) {return 0;}' > conftest.c + if $CC -o conftest.o -fuse-ld=[$]1 $LDFLAGS conftest.c > /dev/null 2>&1 + then + AC_MSG_RESULT([yes]) + fuse_ld_ok=yes + else + AC_MSG_RESULT([no]) + fuse_ld_ok=no + fi + rm -f conftest.c conftest.o + } + + try_set_linker_to() { + AC_MSG_CHECKING([whether linker can be set to [$]1]) + tmp_ld=[$]1 + abs_path=`command -v "$tmp_ld" 2>/dev/null` # get absolute path of $tmp_ld if it isn't already one + ld_path_ok="no" + if test "z$abs_path" != "z" && check_ld_path "$abs_path" && test "x$ld_path_ok" = "xyes"; + then $2="--ld-path=$abs_path" + AC_CHECK_TARGET_TOOL([LD], [$abs_path]) + linker_set_successfully=yes + else # --ld-path does not work or $LD cannot be resolved to an absolute path + fuse_ld_ok=no + if check_fuse_ld "$tmp_ld" && test "x$fuse_ld_ok" = "xyes"; + then $2="-fuse-ld=$tmp_ld" + AC_CHECK_TARGET_TOOL([LD], [$tmp_ld]) + linker_set_successfully=yes + else AC_MSG_WARN(["$tmp_ld could not be set via either '--ld-path' or '-fuse-ld"]) + linker_set_successfully=no + fi + fi + } + + # we are lenient when $LD=ld and just act as if $LD wasn't set and + # enable-ld-override is off + if test "z$LD" != "z" && test "z$LD" != "zld"; + then linker_set_successfully=no + try_set_linker_to "$LD" + if test "z$linker_set_successfully" != "zyes"; + then AC_MSG_FAILURE([ $tmp_ld is an invalid linker. If your C compiler accepts the '--ld-path' flag, + \$LD can be either of an executable name that is in \$PATH *or* a path to an executable. + If your C compiler only supports the '--fuse-ld' flag, \$LD can only be one of the linker flavours supported + by it. Mind that if your C compiler supports '--ld-path', 'configure' will always prefer using an absolute path + to your linker as that is less error-prone.]) + fi + + else # $LD is not set -- we will do the ld-override non-sense + if test "x$enable_ld_override" = "xyes" && test "z$LD" != "zld" && case "$1" in + *-darwin) false ;; # don't do the ld override thing on macos + *) true ;; + esac; + then + AC_MSG_NOTICE(["enable ld override was set and no more specific linker was chosen by setting \$LD, trying to find best possible linker"]) + try_set_linker_to "lld" + if test "z$linker_set_successfully" != "zyes"; + then # ... bail out, just use ld in path + $2="" + AC_CHECK_TARGET_TOOL([LD], [ld]) + fi + else # ld override is not set and $LD not set either + $2="" + AC_CHECK_TARGET_TOOL([LD], [ld]) + fi + fi + + AC_MSG_NOTICE([linker discovery set $2 set to $$2]) + + CHECK_LD_COPY_BUG([$1]) +]) ===================================== m4/find_merge_objects.m4 ===================================== @@ -22,7 +22,6 @@ AC_DEFUN([CHECK_MERGE_OBJECTS],[ ]) AC_DEFUN([FIND_MERGE_OBJECTS],[ - AC_REQUIRE([FIND_LD]) if test -z ${MergeObjsCmd+x}; then AC_MSG_NOTICE([Setting cmd]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b8774df10ffcb4c60992c2f7d172dd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b8774df10ffcb4c60992c2f7d172dd… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] 10 commits: hadrian: fix HLS support
by Rodrigo Mesquita (＠alt-romes) 15 Jul '26

15 Jul '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: ed261a7e by Cheng Shao at 2026-07-14T17:59:38-04:00 hadrian: fix HLS support This patch fixes hadrian's HLS support so one can rely on HLS when working on the hadrian codebase. Fixes #27480. Not building/linking shared libraries for hadrian is a severely premature optimization; this top-level setting in `cabal.project` only affects home packages while the dependencies in the cabal store are built with vanilla/dynamic anyway, and even adding dynamic builds to home packages would not be costly due to cabal's usage of `-dynamic-too`. - - - - - eee8ec5b by Cheng Shao at 2026-07-14T18:00:20-04:00 compiler: fix miscompiled %load_relaxed, add missing %store_relaxed This patch fixes the %load_relaxed cmm primop compilation logic to correctly use relaxed memory ordering, and adds the missing %store_relaxed primop. Parsing logic of %load/%store with explicit ordering is covered in the AtomicFetch test case. Fixes #27483. Co-authored-by: Codex <codex(a)openai.com> - - - - - 1718230f by Alan Zimmerman at 2026-07-14T18:01:06-04:00 EPA: Keep binds and sigs together in HsValBindsLR We combine them into a single list for GhcPs, wrapped in the ValBind data type, which is the bind equivalent of ValD, having constructors for binds and sigs. This simplifies exact print processing, especially when using it to update the contents of local binds, as we no longer need AnnSortKey BindTag - - - - - 6bd1ad2a by Andreas Klebinger at 2026-07-14T18:01:49-04:00 Bump nofib submodule to account for MonoLocalBinds. New versions of GHC enable MonoLocalBinds by default. This breaks some of the benchmarks. I've fixed this and this bump pulls in that fix. - - - - - 7eb0f1c9 by Cheng Shao at 2026-07-14T18:02:31-04:00 testsuite: fix bytecodeIPE test under +ipe flavours This patch fixes the bytecodeIPE test under +ipe flavours. It used to fail under +ipe because the RTS is built with IPE info, then stg_AP_info in RTS carries IPE info, so whereFrom wouldn't return Nothing. Now the test checks IPE info of a datacon in the ghci-loaded module which is not affected by whether the RTS is built with IPE info or not. Fixes #27498. Co-authored-by: Codex <codex(a)openai.com> - - - - - ef038aae by cydparser at 2026-07-15T04:35:41-04:00 Reduce bytes allocated for `capabilities` in RTS (fixes #27487) In rts/Capability.c, `capabilities` is an array of pointers, but it was allocated as if it were an array of Capability's. - - - - - d377e83e by Cheng Shao at 2026-07-15T04:36:27-04:00 rts: fix missing UNTAG in stg_readTVarIOzh This patch fixes missing UNTAG on the current value closure read from StgTVar. UNTAG is a no-op when it's stg_TREC_HEADER_info which is word aligned; it may be a tagged closure, and reading info table from the tagged address is an unaligned load which may cause issues on platforms with strict alignment requirements. Co-authored-by: Codex <codex(a)openai.com> - - - - - 8ed03842 by Cheng Shao at 2026-07-15T04:36:27-04:00 rts: fix missing UNTAG in stg_control0zh_ll This patch fixes missing UNTAG on the cont closure returned by captureContinuationAndAbort. In case it's not NULL, captureContinuationAndAbort returns a tagged StgContinuation closure, in which case it must be untagged before accessing the apply_mask_frame field. In the past it worked out of luck: when apply_mask_frame was NULL then mask_frame_offset is also 0 so the control flow didn't diverge to a wrong path. Still, this is horribly wrong and will crash once StgContinuation struct is refactored and fields are shuffled around. Co-authored-by: Codex <codex(a)openai.com> - - - - - 5aa7000a by Cheng Shao at 2026-07-15T04:37:08-04:00 compiler: fix redundant AP thunk codegen when not using -ticky-ap-thunk This patch fixes a double negation confusion in !7525 that results in some redundant AP thunk code generation when not using -ticky-ap-thunk. Now, we use `stgToCmmUseStdApThunk` to indicate whether precomputed AP thunks in the RTS should be used, which defaults to `True`, unless `-ticky-ap-thunk` is passed. `-finfo-table-map` now also implies `-ticky-ap-thunk`, since when doing IPE profiling we want the generated AP thunks to be unique. Fixes #27502. ------------------------- Metric Decrease: T3064 ------------------------- Co-authored-by: Codex <codex(a)openai.com> - - - - - b6342259 by Simon Peyton Jones at 2026-07-15T13:48:21+01:00 Major patch to re-engineer known-key names This big patch implements the New Plan for known-key names, described in #27013. Read the big Note [Overview of known-key names] in GHC.Types.Name Some things had to be reworked slightly to accomodate the new known-keys design. A significant one was the generation of auxiliary KindRep bindings, which was greatly simplified. Note [Grand plan for Typeable] was updated accordingly. Another example: GHC.Internal.CString was merged into GHC.Internal.Types. Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com> The couple hundreds of hours spent here by Rodrigo were sponsored by Well-Typed Metrics: compile_time/bytes allocated ------------------------------------- Baseline Test Metric value New value Change ------------------------------------------------------------------------------------------ MultiComponentModules100(normal) ghc/alloc 24,312,779,672 24,990,470,432 +2.8% BAD MultiComponentModulesRecomp(normal) ghc/alloc 601,924,960 621,884,888 +3.3% BAD MultiComponentModulesRecomp100(normal) ghc/alloc 11,884,065,432 12,531,373,704 +5.4% BAD MultiLayerModules(normal) ghc/alloc 3,861,537,072 3,706,919,512 -4.0% GOOD T13701(normal) ghc/alloc 3,517,246,392 3,237,179,616 -8.0% GOOD T13820(normal) ghc/alloc 28,961,056 29,663,208 +2.4% BAD T14697(normal) ghc/alloc 472,044,184 443,550,048 -6.0% GOOD T18140(normal) ghc/alloc 47,905,664 49,115,808 +2.5% BAD T4801(normal) ghc/alloc 269,339,096 263,432,040 -2.2% GOOD T783(normal) ghc/alloc 341,112,672 333,339,952 -2.3% GOOD hard_hole_fits(normal) ghc/alloc 222,164,728 213,433,808 -3.9% GOOD mhu-perf(normal) ghc/alloc 49,011,440 46,706,280 -4.7% GOOD geo. mean +0.1% minimum -8.0% maximum +5.4% All performance regressions were investigated in depth. The surviving ones: - MultiComponentModules100, MultiComponentModulesRecomp100, MultiComponentModulesRecomp regresses because existing bugs that make an additional implicit edge do too much redundant work: #27053 and #27461 - T13820, T18140, T10547, T13035 regress because we load an additional interface and associated Names for GHC.Essentials. ------------------------- Metric Decrease: MultiLayerModules T13701 T14697 T26989 T4801 T783 hard_hole_fits mhu-perf size_hello_obj Metric Increase: LinkableUsage01 MultiComponentModules100 MultiComponentModulesRecomp MultiComponentModulesRecomp100 T10547 T13035 T13820 T18140 T20049 ------------------------- - - - - - 761 changed files: - + changelog.d/fix-cmm-atomic-load-store - + changelog.d/fix-use-std-ap-thunk - + changelog.d/refactor-known-names - compiler/GHC.hs - + compiler/GHC/Builtin.hs - + compiler/GHC/Builtin/KnownKeys.hs - + compiler/GHC/Builtin/KnownOccs.hs - + compiler/GHC/Builtin/Modules.hs - − compiler/GHC/Builtin/Names.hs - − compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/PrimOps/Casts.hs - compiler/GHC/Builtin/PrimOps/Ids.hs - + compiler/GHC/Builtin/TH.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - − compiler/GHC/Builtin/Utils.hs - + compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Builtin/Types/Prim.hs → compiler/GHC/Builtin/WiredIn/Prim.hs - compiler/GHC/Builtin/Types/Literals.hs → compiler/GHC/Builtin/WiredIn/TypeLits.hs - compiler/GHC/Builtin/Types.hs → compiler/GHC/Builtin/WiredIn/Types.hs - compiler/GHC/Builtin/Types.hs-boot → compiler/GHC/Builtin/WiredIn/Types.hs-boot - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/LiberateCase.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Config/Tidy.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/KnotVars.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main/Hsc.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/Call.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc/Check.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Ppr.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Types.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Env.hs - − compiler/GHC/Iface/Env.hs-boot - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Plugins.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs - compiler/GHC/StgToCmm/DataCon.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Functor.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Foreign.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Literal.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/RepType.hs - compiler/GHC/Types/TyThing.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Unit.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Binary.hs - − compiler/GHC/Utils/Binary/Typeable.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/ghc.cabal.in - docs/users_guide/separate_compilation.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - hadrian/cabal.project - libraries/base/base.cabal.in - libraries/base/src/Control/Applicative.hs - libraries/base/src/Control/Concurrent.hs - libraries/base/src/Control/Concurrent/Chan.hs - libraries/base/src/Control/Concurrent/QSem.hs - libraries/base/src/Control/Concurrent/QSemN.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Bifoldable.hs - libraries/base/src/Data/Bifoldable1.hs - libraries/base/src/Data/Bifunctor.hs - libraries/base/src/Data/Bitraversable.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Complex.hs - libraries/base/src/Data/Data.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/Data/Foldable1.hs - libraries/base/src/Data/Functor/Classes.hs - libraries/base/src/Data/Functor/Compose.hs - libraries/base/src/Data/Functor/Contravariant.hs - libraries/base/src/Data/Functor/Product.hs - libraries/base/src/Data/Functor/Sum.hs - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/List/NubOrdSet.hs - libraries/base/src/Data/Semigroup.hs - libraries/base/src/Data/Version.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/ByteOrder.hs - + libraries/base/src/GHC/Essentials.hs - libraries/base/src/GHC/Exts.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/Numeric.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/CPUTime/Posix/ClockGetTime.hsc - libraries/base/src/System/CPUTime/Posix/RUsage.hsc - libraries/base/src/System/CPUTime/Unsupported.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO.hs - libraries/base/src/System/IO/OS.hs - libraries/base/src/System/IO/Unsafe.hs - libraries/base/src/System/Info.hs - libraries/base/src/System/Timeout.hs - libraries/base/src/Text/Printf.hs - libraries/base/src/Text/Read.hs - libraries/base/src/Text/Show/Functions.hs - libraries/binary - libraries/ghc-experimental/src/Data/Sum/Experimental.hs - libraries/ghc-experimental/src/Data/Tuple/Experimental.hs - libraries/ghc-experimental/src/GHC/Profiling/Eras.hs - libraries/ghc-experimental/src/Prelude/Experimental.hs - libraries/ghc-internal/codepages/MakeTable.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Arr.hs - libraries/ghc-internal/src/GHC/Internal/ArrayArray.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/GMP.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Primitives.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/WordArray.hs - libraries/ghc-internal/src/GHC/Internal/Bits.hs - libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs - libraries/ghc-internal/src/GHC/Internal/CString.hs - libraries/ghc-internal/src/GHC/Internal/Char.hs - libraries/ghc-internal/src/GHC/Internal/Classes.hs - libraries/ghc-internal/src/GHC/Internal/Classes/IP.hs - libraries/ghc-internal/src/GHC/Internal/Clock.hsc - libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Bound.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Conc/POSIX.hs - libraries/ghc-internal/src/GHC/Internal/Conc/POSIX/Const.hsc - libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs - libraries/ghc-internal/src/GHC/Internal/ConsoleHandler.hsc - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Category.hs - libraries/ghc-internal/src/GHC/Internal/Control/Concurrent/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/IO/Class.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs - libraries/ghc-internal/src/GHC/Internal/Data/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Data/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Data/Dynamic.hs - libraries/ghc-internal/src/GHC/Internal/Data/Either.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Function.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Data/IORef.hs - libraries/ghc-internal/src/GHC/Internal/Data/List.hs - libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Data/Monoid.hs - libraries/ghc-internal/src/GHC/Internal/Data/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Proxy.hs - libraries/ghc-internal/src/GHC/Internal/Data/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Data/Semigroup/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Coercion.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Equality.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Data/Void.hs - libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs - libraries/ghc-internal/src/GHC/Internal/Desugar.hs - libraries/ghc-internal/src/GHC/Internal/Encoding/UTF8.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs-boot - libraries/ghc-internal/src/GHC/Internal/Environment.hs - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/src/GHC/Internal/Event/Arr.hs - libraries/ghc-internal/src/GHC/Internal/Event/Array.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/IntTable.hs - libraries/ghc-internal/src/GHC/Internal/Event/IntVar.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs - libraries/ghc-internal/src/GHC/Internal/Event/PSQ.hs - libraries/ghc-internal/src/GHC/Internal/Event/Poll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimeOut.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs - libraries/ghc-internal/src/GHC/Internal/Event/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/Clock.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/FFI.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot - libraries/ghc-internal/src/GHC/Internal/ExecutionStack.hs - libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint/Type.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Float/ConversionUtils.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/ConstPtr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Types.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/ForeignPtr/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Alloc.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Array.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Pool.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Storable.hs - libraries/ghc-internal/src/GHC/Internal/ForeignPtr.hs - libraries/ghc-internal/src/GHC/Internal/ForeignSrcLang.hs - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs - libraries/ghc-internal/src/GHC/Internal/GHCi.hs - libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - libraries/ghc-internal/src/GHC/Internal/Generics.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Buffer.hs - libraries/ghc-internal/src/GHC/Internal/IO/BufferedIO.hs - libraries/ghc-internal/src/GHC/Internal/IO/Device.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage/API.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage/Table.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Iconv.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Latin1.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF16.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF32.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF8.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Common.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Flock.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/NoOp.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs - libraries/ghc-internal/src/GHC/Internal/IO/SubSystem.hs - libraries/ghc-internal/src/GHC/Internal/IO/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/IO/Windows/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/IO/Windows/Handle.hsc - libraries/ghc-internal/src/GHC/Internal/IOArray.hs - libraries/ghc-internal/src/GHC/Internal/IORef.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Int.hs - libraries/ghc-internal/src/GHC/Internal/IsList.hs - libraries/ghc-internal/src/GHC/Internal/Ix.hs - libraries/ghc-internal/src/GHC/Internal/JS/Foreign/Callback.hs - libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/ghc-internal/src/GHC/Internal/Lexeme.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Magic/Dict.hs - libraries/ghc-internal/src/GHC/Internal/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs-boot - libraries/ghc-internal/src/GHC/Internal/Numeric.hs - libraries/ghc-internal/src/GHC/Internal/OverloadedLabels.hs - libraries/ghc-internal/src/GHC/Internal/Pack.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Ext.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Panic.hs - libraries/ghc-internal/src/GHC/Internal/Prim/PtrEq.hs - libraries/ghc-internal/src/GHC/Internal/Profiling.hs - libraries/ghc-internal/src/GHC/Internal/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs-boot - libraries/ghc-internal/src/GHC/Internal/Records.hs - libraries/ghc-internal/src/GHC/Internal/ST.hs - libraries/ghc-internal/src/GHC/Internal/STM.hs - libraries/ghc-internal/src/GHC/Internal/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Show.hs - libraries/ghc-internal/src/GHC/Internal/Stable.hs - libraries/ghc-internal/src/GHC/Internal/StableName.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs-boot - libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Types.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Stats.hsc - libraries/ghc-internal/src/GHC/Internal/Storable.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - libraries/ghc-internal/src/GHC/Internal/System/Mem.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Types.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadP.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadPrec.hs - libraries/ghc-internal/src/GHC/Internal/Text/Read/Lex.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghc-internal/src/GHC/Internal/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/TypeError.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits/Internal.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Unicode.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/DerivedCoreProperties.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/GeneralCategory.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleLowerCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleTitleCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleUpperCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Version.hs - libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Conc.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Conc/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs - libraries/ghc-internal/src/GHC/Internal/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs - libraries/ghc-internal/src/GHC/Internal/Windows.hs - libraries/ghc-internal/src/GHC/Internal/Word.hs - libraries/ghc-internal/tools/ucd2haskell/exe/UCD2Haskell/ModuleGenerators.hs - libraries/ghc-prim/Dummy.hs - libraries/ghc-prim/ghc-prim.cabal - libraries/template-haskell/Language/Haskell/TH/Lib.hs - nofib - rts/Capability.c - rts/ContinuationOps.cmm - rts/PrimOps.cmm - rts/include/rts/RtsToHsIface.h - testsuite/tests/ado/T13242a.stderr - testsuite/tests/annotations/should_fail/annfail10.stderr - testsuite/tests/backpack/cabal/bkpcabal07/Makefile - testsuite/tests/backpack/should_compile/T20396.stderr - testsuite/tests/backpack/should_fail/bkpfail17.stderr - testsuite/tests/cabal/T12485/Makefile - + testsuite/tests/cabal/T27013a/Makefile - + testsuite/tests/cabal/T27013a/Setup.hs - + testsuite/tests/cabal/T27013a/all.T - + testsuite/tests/cabal/T27013a/composition.cabal - + testsuite/tests/cabal/T27013a/src/Data/Composition.hs - + testsuite/tests/cabal/T27013d/Composition.hs - + testsuite/tests/cabal/T27013d/Makefile - + testsuite/tests/cabal/T27013d/T27013d.stdout - + testsuite/tests/cabal/T27013d/all.T - testsuite/tests/callarity/unittest/CallArity1.hs - testsuite/tests/cmm/should_run/AtomicFetch.hs - testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm - testsuite/tests/corelint/LintEtaExpand.hs - testsuite/tests/corelint/T21115b.stderr - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/deSugar/should_compile/T13208.stdout - testsuite/tests/deSugar/should_compile/T16615.stderr - testsuite/tests/deSugar/should_compile/T2431.stderr - testsuite/tests/default/DefaultImportFail01.stderr - testsuite/tests/default/DefaultImportFail02.stderr - testsuite/tests/default/DefaultImportFail03.stderr - testsuite/tests/default/DefaultImportFail04.stderr - testsuite/tests/default/DefaultImportFail05.stderr - testsuite/tests/default/DefaultImportFail07.stderr - testsuite/tests/default/T25775.stderr - testsuite/tests/deriving/should_compile/T14682.stderr - testsuite/tests/deriving/should_compile/T20496.stderr - testsuite/tests/diagnostic-codes/codes.stdout - + testsuite/tests/driver/T27013b/Makefile - + testsuite/tests/driver/T27013b/T27013b.stdout - + testsuite/tests/driver/T27013b/X.hs - + testsuite/tests/driver/T27013b/all.T - + testsuite/tests/driver/T27013c/Makefile - + testsuite/tests/driver/T27013c/T27013c.stdout - + testsuite/tests/driver/T27013c/X.hs - + testsuite/tests/driver/T27013c/all.T - + testsuite/tests/driver/T27013e/T27013e.hs - + testsuite/tests/driver/T27013e/T27013e.stderr - + testsuite/tests/driver/T27013e/all.T - + testsuite/tests/driver/T27013f/T27013f.hs - + testsuite/tests/driver/T27013f/T27013f.stderr - + testsuite/tests/driver/T27013f/all.T - testsuite/tests/driver/T3007/A/Internal.hs - testsuite/tests/driver/T3007/Makefile - testsuite/tests/driver/make-prim/Makefile - testsuite/tests/driver/recomp24656/Makefile - testsuite/tests/driver/recomp24656/recomp24656.stdout - testsuite/tests/ghc-api/T8628.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghci.debugger/scripts/break006.stderr - testsuite/tests/ghci.debugger/scripts/print019.stderr - testsuite/tests/ghci/scripts/all.T - testsuite/tests/ghci/scripts/bytecodeIPE.hs - testsuite/tests/hiefile/should_run/T23120.stdout - testsuite/tests/iface/IfaceSharingIfaceType.hs - testsuite/tests/iface/IfaceSharingName.hs - testsuite/tests/indexed-types/should_fail/T12522a.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/javascript/T24495.hs - testsuite/tests/numeric/should_compile/T14170.stdout - testsuite/tests/numeric/should_compile/T14465.stdout - testsuite/tests/numeric/should_compile/T7116.stdout - testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr - testsuite/tests/package/all.T - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/parser/should_fail/T16270h.hs - testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr - testsuite/tests/patsyn/should_fail/T26465.stderr - testsuite/tests/perf/should_run/ByteCodeAsm.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInvalid.hs - testsuite/tests/plugins/defaulting-plugin/DefaultMultiParam.hs - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/simple-plugin/Simple/ReplacePlugin.hs - testsuite/tests/plugins/static-plugins.stdout - testsuite/tests/printer/Test20297.stdout - testsuite/tests/profiling/should_run/callstack001.stdout - testsuite/tests/profiling/should_run/callstack002.stderr - testsuite/tests/profiling/should_run/callstack002.stdout - testsuite/tests/rename/should_compile/T3103/Foreign/Ptr.hs - testsuite/tests/rename/should_compile/T3103/GHC/Base.lhs - testsuite/tests/rename/should_compile/T3103/GHC/Word.hs - testsuite/tests/rename/should_compile/T3103/test.T - testsuite/tests/roles/should_compile/Roles1.stderr - testsuite/tests/roles/should_compile/Roles13.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles2.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr - testsuite/tests/simplCore/should_compile/T13543.stderr - testsuite/tests/simplCore/should_compile/T16038/T16038.stdout - testsuite/tests/simplCore/should_compile/T3717.stderr - testsuite/tests/simplCore/should_compile/T3772.stdout - testsuite/tests/simplCore/should_compile/T4908.stderr - testsuite/tests/simplCore/should_compile/T4930.stderr - testsuite/tests/simplCore/should_compile/T7360.stderr - testsuite/tests/simplCore/should_compile/T8274.stdout - testsuite/tests/simplCore/should_compile/T9400.stderr - testsuite/tests/simplCore/should_compile/noinline01.stderr - testsuite/tests/simplCore/should_compile/par01.stderr - testsuite/tests/simplCore/should_compile/rule2.stderr - testsuite/tests/simplCore/should_compile/str-rules.hs - testsuite/tests/tcplugins/ArgsPlugin.hs - testsuite/tests/tcplugins/EmitWantedPlugin.hs - testsuite/tests/tcplugins/RewritePlugin.hs - testsuite/tests/tcplugins/T26395_Plugin.hs - testsuite/tests/tcplugins/TyFamPlugin.hs - testsuite/tests/th/T14741.hs - testsuite/tests/th/T21547.stderr - testsuite/tests/th/T26568.stderr - testsuite/tests/th/TH_Roles2.stderr - + testsuite/tests/th/TH_pragmaSpecOld.hs - + testsuite/tests/th/TH_pragmaSpecOld.stderr - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_compile/T13032.stderr - testsuite/tests/typecheck/should_compile/T14273.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes2.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T12921.stderr - testsuite/tests/typecheck/should_fail/T14884.stderr - testsuite/tests/typecheck/should_fail/T15883b.stderr - testsuite/tests/typecheck/should_fail/T15883c.stderr - testsuite/tests/typecheck/should_fail/T15883d.stderr - testsuite/tests/typecheck/should_fail/T21130.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T5095.stderr - testsuite/tests/typecheck/should_fail/T7279.stderr - testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_PatternBindingExistential.stderr - testsuite/tests/typecheck/should_fail/tcfail072.stderr - testsuite/tests/typecheck/should_fail/tcfail097.stderr - testsuite/tests/typecheck/should_fail/tcfail133.stderr - testsuite/tests/typecheck/should_run/T22510.stdout - testsuite/tests/unboxedsums/UbxSumLevPoly.hs - testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs - testsuite/tests/warnings/should_compile/DerivingTypeable.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/genprimopcode/Main.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.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/8e2e58972c7a857fbc4a91f028f7ba… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e2e58972c7a857fbc4a91f028f7ba… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/9.14.2-backports] 14 commits: Reference correct package in error messages for reexported modules
by Zubin (＠wz1000) 15 Jul '26

15 Jul '26

Zubin pushed to branch wip/9.14.2-backports at Glasgow Haskell Compiler / GHC Commits: 1aa2821e by Simon Hengel at 2026-07-15T17:13:14+05:30 Reference correct package in error messages for reexported modules (fixes #27417) (cherry picked from commit a805b2a25021606b30d250e084d4beecbfac0d0a) - - - - - 112110e6 by Luite Stegeman at 2026-07-15T17:13:14+05:30 rts: handle large AP closures in compacting GC The function update_fwd_large in the compacting GC could run into an unexpected object with the following error: internal error: update_fwd_large: unknown/strange object 24 Closure type 24 is the AP closure, which was not handled in upd_fwd_large. This patch adds handling them. fixes #27434 (cherry picked from commit cca0d58963f802a8b2e43aa2dbc58592f8ad07bb) - - - - - faf5f76d by Cheng Shao at 2026-07-15T17:13:14+05:30 compiler: fix missing handling of CmmUnsafeForeignCall node in LayoutStack This patch fixes missing handling of `CmmUnsafeForeignCall` middle node in the `LayoutStack` pass. Before proc-points splitting, this pass computes liveliness of local registers, and spills those alive across a Cmm native call onto the stack. It need to traverse all middle nodes in each block and check whether a local register is an assignee, if so then the previous mapping in `sm_regs` is invalidated and needs to be dropped. However, it didn't handle `CmmUnsafeForeignCall` node which may also assign to a local register. When proc-points splitting is enabled, this can produce an invalid basic block that doesn't properly backup the updated local register to the stack before doing a Cmm call, resulting in completely invalid runtime behavior. The patch also adds a `T27447` regression test. With no-TNTC or with LLVM backend, without the fix the test case would output a stale 0x1111111111111111 value, instead of the expected 0x2222222222222222 output. Fixes #27447. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 3f00f234d0d5b3b3b2a23a5dc70ce372eb9bbdb4) - - - - - 2b55b40a by Cheng Shao at 2026-07-15T17:13:14+05:30 ci: use treeless fetch for perf notes This patch improves the ci logic for fetching perf notes by using treeless fetch (https://github.blog/open-source/git/get-up-to-speed-with-partial-clone-and-…) to avoid downloading all blobs of the perf notes repo at once, and only fetch the actually required blobs on-demand when needed. This makes the initial `test-metrics.sh pull` operation much faster, and also more robust, since we are seeing an increasing rate of 504 errors in CI when fetching all perf notes at once, which is a major source of CI flakiness at this point. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 3c0013778b4459c1f8e56cd0dc2600f5bb3769d2) - - - - - fcc4231f by mangoiv at 2026-07-15T17:13:14+05:30 ci: retry fetching test metrics Retry fetching test metrics to make the CI not fail if the services is temporarily unavailable (cherry picked from commit b7e24044fde064cb3f0d44c36872a86d024cd7d4) - - - - - 03a35805 by Zubin Duggal at 2026-07-15T17:13:15+05:30 Bump semaphore-compat submodule to 2.0.1 This versions includes some cruicial fixes for darwin (cherry picked from commit 4180af3f71754472dbd49b85179b25fd29bd9998) - - - - - c1c0031f by Zubin Duggal at 2026-07-15T17:13:15+05:30 CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent In #25924, we segfault because speculation forces a projection out of a RUBBISH dictionary (which we generated because it absent). Solution: Don't speculate on bindings we already know are absent. Fixes 25924 (cherry picked from commit 9b714c4c833461c621f0a050680848d7248aa57e) - - - - - 6e514e1d by Zubin Duggal at 2026-07-15T17:13:15+05:30 Don't make absent fillers for terminating types In #25924 we discovered that we could speculatively evaluate an absent filler for a dictionary, and project a field (a superclass selector) out of it, resulting in segfaults. Solution: Never make an absent filler or rubbish literal for a terminating type like a dictionary. mkAbsentFiller returns Nothing for isTerminatingType, so worker/wrapper and the specialiser keep the real argument instead. Some small metric decreases because we do a little less work in the simplifier now. Metric Decrease: T9872a T9872b T9872c TcPlugin_RewritePerf (cherry picked from commit 4a59b3eece9b7106fcbe73d2d06a49755be4ea8f) - - - - - 30f20fff by Andreas Klebinger at 2026-07-15T17:13:15+05:30 Fix a profiling race condition resulting in segfaults. StgToCmm: Don't assume tagged FUN closures in closureCodeBody. When entering a closure the self/node pointer might not be tagged in some situations when a thunk is evaluated by multiple threads. So we most AND away the tag bits rather than subtracting an expected tag. Apply.cmm: Fix a race condition occuring when a thunk is mutated during GC. In stg_ap_0_fast when might need to run GC before entering a thunk. If this happens another thread or the GC itself might mutate the closure making entering it no longer valid. We now check for this. Add test and changelog for #27123 fixes. (cherry picked from commit ed09895d7de1ca116a561868c151fd825a16ad0c) - - - - - 9f78fae4 by Cheng Shao at 2026-07-15T17:13:15+05:30 ghc-heap: fix invalid srtlen returned by peekItbl when no-TNTC This patch fixes the no-TNTC code path of `peekItbl` so that it looks at the right memory address when reading the `srt` field from the `StgInfoTable_` struct. Also adds a `T27465` regression test that reproduces the bug on no-TNTC builds before the fix. Fixes #27465. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 67c03eb2c762fdfeb646eb8345341173dd4268b2) - - - - - 7165f6cc by Cheng Shao at 2026-07-15T17:13:15+05:30 compiler: fix miscompiled %load_relaxed, add missing %store_relaxed This patch fixes the %load_relaxed cmm primop compilation logic to correctly use relaxed memory ordering, and adds the missing %store_relaxed primop. Parsing logic of %load/%store with explicit ordering is covered in the AtomicFetch test case. Fixes #27483. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit eee8ec5b25ef0f83ba4822e7a0a941df7b0bec5f) - - - - - 6c0eb2c7 by Cheng Shao at 2026-07-15T17:13:15+05:30 rts: fix missing UNTAG in stg_readTVarIOzh This patch fixes missing UNTAG on the current value closure read from StgTVar. UNTAG is a no-op when it's stg_TREC_HEADER_info which is word aligned; it may be a tagged closure, and reading info table from the tagged address is an unaligned load which may cause issues on platforms with strict alignment requirements. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit d377e83e51d39a06e1f0bf2e35a923a3210b21a2) - - - - - 77298354 by Cheng Shao at 2026-07-15T17:13:15+05:30 rts: fix missing UNTAG in stg_control0zh_ll This patch fixes missing UNTAG on the cont closure returned by captureContinuationAndAbort. In case it's not NULL, captureContinuationAndAbort returns a tagged StgContinuation closure, in which case it must be untagged before accessing the apply_mask_frame field. In the past it worked out of luck: when apply_mask_frame was NULL then mask_frame_offset is also 0 so the control flow didn't diverge to a wrong path. Still, this is horribly wrong and will crash once StgContinuation struct is refactored and fields are shuffled around. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 8ed038421a20e3e4e681973b2f5098e5bd2144b5) - - - - - 883a75bd by Cheng Shao at 2026-07-15T17:13:15+05:30 compiler: fix redundant AP thunk codegen when not using -ticky-ap-thunk This patch fixes a double negation confusion in !7525 that results in some redundant AP thunk code generation when not using -ticky-ap-thunk. Now, we use `stgToCmmUseStdApThunk` to indicate whether precomputed AP thunks in the RTS should be used, which defaults to `True`, unless `-ticky-ap-thunk` is passed. `-finfo-table-map` now also implies `-ticky-ap-thunk`, since when doing IPE profiling we want the generated AP thunks to be unique. Fixes #27502. ------------------------- Metric Decrease: T3064 ------------------------- Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 5aa7000ae246ae6a706437799338295b5801a629) - - - - - 60 changed files: - .gitlab/test-metrics.sh - + changelog.d/T27123.md - + changelog.d/fix-absent-dict-projection - + changelog.d/fix-cmm-atomic-load-store - + changelog.d/fix-compacting-gc-ap-27434 - + changelog.d/fix-layout-stack-fcall - + changelog.d/fix-peekitbl-no-tntc - + changelog.d/fix-use-std-ap-thunk - + changelog.d/reexported-module-errors - changelog.d/semaphore-v2 - compiler/GHC/Cmm/LayoutStack.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Iface/Errors.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs - compiler/GHC/Types/Literal.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI/Exception.hs - hadrian/src/Settings/Warnings.hs - + libraries/ghc-heap/tests/T27465.hs - + libraries/ghc-heap/tests/T27465.stdout - libraries/ghc-heap/tests/all.T - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - libraries/semaphore-compat - rts/Apply.cmm - rts/ContinuationOps.cmm - rts/PrimOps.cmm - rts/sm/Compact.c - testsuite/tests/cmm/should_run/AtomicFetch.hs - testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm - + testsuite/tests/cmm/should_run/T27447.hs - + testsuite/tests/cmm/should_run/T27447.stdout - + testsuite/tests/cmm/should_run/T27447_cmm.cmm - testsuite/tests/cmm/should_run/all.T - + testsuite/tests/core-to-stg/T25924/B.hs - + testsuite/tests/core-to-stg/T25924/Main.hs - + testsuite/tests/core-to-stg/T25924/all.T - + testsuite/tests/core-to-stg/T25924a.hs - + testsuite/tests/core-to-stg/T25924a.stdout - testsuite/tests/core-to-stg/all.T - testsuite/tests/dmdanal/should_compile/T18982.stderr - + testsuite/tests/package/ImportReexport.hs - + testsuite/tests/package/ImportReexport.stderr - testsuite/tests/package/all.T - + testsuite/tests/rts/T27123.hs - + testsuite/tests/rts/T27434.hs - + testsuite/tests/rts/T27434.stdout - testsuite/tests/rts/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0906c7dc9fad3de876ad3246eb0238… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0906c7dc9fad3de876ad3246eb0238… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/external-unit-db-cache] 2 commits: WIP: Introduce UnitIndex for global data
by Hannes Siebenhandl (＠fendor) 15 Jul '26

15 Jul '26

Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: a91af86b by fendor at 2026-07-14T13:12:54+02:00 WIP: Introduce UnitIndex for global data - - - - - 7ffa36d7 by fendor at 2026-07-15T13:31:58+02:00 Split State.hs into many more modules - - - - - 21 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/External/Database.hs - + compiler/GHC/Unit/External/Index.hs - + compiler/GHC/Unit/External/ModuleOrigin.hs - + compiler/GHC/Unit/External/Providers.hs - + compiler/GHC/Unit/External/Validate.hs - + compiler/GHC/Unit/External/Visibility.hs - + compiler/GHC/Unit/External/Wired.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/State.hs-boot - compiler/GHC/Unit/Types.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - libraries/ghc-boot/GHC/Unit/Database.hs - utils/haddock/haddock-api/src/Haddock.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -671,7 +671,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do logger <- getLogger hsc_env <- getSession - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hsc_unit_index hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let upd hue = @@ -760,7 +760,7 @@ setProgramDynFlags_ invalidate_needed dflags = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph old_unit_env) - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_eud old_unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index old_unit_env) (ue_eud old_unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants pure HomeUnitEnv @@ -779,6 +779,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env , ue_eud = ue_eud old_unit_env + , ue_unit_index = ue_unit_index old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) @@ -837,6 +838,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_eps = ue_eps unit_env0 , ue_module_graph = ue_module_graph unit_env0 , ue_eud = ue_eud unit_env0 + , ue_unit_index = ue_unit_index unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -884,7 +886,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph unit_env) - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_eud unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index unit_env) (ue_eud unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants pure HomeUnitEnv ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -175,6 +175,8 @@ withBkpSession :: UnitId -> BkpM a withBkpSession cid insts deps session_type do_this = do dflags <- getDynFlags + env <- getSession + unitIndex <- liftIO $ hscUnitIndex env let cid_fs = unitFS cid is_primary = False uid_str = unpackFS (mkInstantiatedUnitHash cid insts) @@ -194,8 +196,8 @@ withBkpSession cid insts deps session_type do_this = do | otherwise = sub_comp (key_base p) mk_temp_env hsc_env = - hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env - mk_temp_dflags unit_state dflags = dflags + hscUpdateFlags (\dflags -> mk_temp_dflags unitIndex (hsc_units hsc_env) dflags) hsc_env + mk_temp_dflags unit_index unit_state dflags = dflags { backend = case session_type of TcSession -> noBackend _ -> backend dflags @@ -242,7 +244,7 @@ withBkpSession cid insts deps session_type do_this = do , importPaths = [] -- Synthesize the flags , packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnit unit_state + let uid = unwireUnit unit_index $ renameHoleUnit unit_state (listToUFM insts) uid0 in ExposePackage (showSDoc dflags @@ -349,9 +351,9 @@ buildUnit session cid insts lunit = do | otherwise = [Nothing] linkables <- liftIO $ catMaybes <$> concatHpt takeLinkables (hsc_HPT hsc_env) + unit_index <- liftIO $ hscUnitIndex hsc_env let obj_files = concatMap linkableFiles linkables - state = hsc_units hsc_env compat_fs = unitIdFS cid compat_pn = PackageName compat_fs @@ -377,7 +379,7 @@ buildUnit session cid insts lunit = do -- really used for anything, so we leave it -- blank for now. TcSession -> [] - _ -> map (toUnitId . unwireUnit state) + _ -> map (toUnitId . unwireUnit unit_index) $ deps ++ [ moduleUnit mod | (_, mod) <- insts , not (isHoleModule mod) ], @@ -449,7 +451,7 @@ addUnit u = do { packageDBFlags = packageDBFlags dflags0 ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] } - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 eud (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_unit_index old_unit_env) eud (hsc_all_home_unit_ids hsc_env) -- update platform constants @@ -467,6 +469,7 @@ addUnit u = do , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env , ue_eud = ue_eud old_unit_env + , ue_unit_index = ue_unit_index old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -13,6 +13,8 @@ module GHC.Driver.Env , hsc_HUE , hsc_HUG , hsc_all_home_unit_ids + , hscUnitIndex + , hsc_unit_index , hscUpdateLoggerFlags , hscUpdateHUG , hscInsertHPT @@ -230,6 +232,12 @@ hscEUD = readExternalUnitDatabases . hscEUDC hscEUDC :: HscEnv -> ExternalUnitDatabaseCache UnitId hscEUDC hsc_env = ue_eud (hsc_unit_env hsc_env) +hscUnitIndex :: HscEnv -> IO UnitIndex +hscUnitIndex hsc_env = readIORef $ ue_unit_index (hsc_unit_env hsc_env) + +hsc_unit_index :: HscEnv -> IORef UnitIndex +hsc_unit_index hsc_env = ue_unit_index (hsc_unit_env hsc_env) + -------------------------------------------------------------------------------- -- * Queries on Transitive Closure -------------------------------------------------------------------------------- ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -131,7 +131,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do let hue_flags = homeUnitEnv_dflags homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv - (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscEUDC hsc_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hsc_unit_index hsc_env) (hscEUDC hsc_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants emptyHpt <- liftIO $ emptyHomePackageTable ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -126,8 +126,8 @@ Prefer `env_ut :: Char` and -- for fast ordering and equality tests. You should generate these with -- the functions from the 'UniqSupply' module -- --- These are sometimes also referred to as \"keys\" in comments in GHC. newtype Unique = MkUnique Word64 +-- These are sometimes also referred to as \"keys\" in comments in GHC. data UniqueTag = AlphaTyVarTag ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -131,6 +131,7 @@ import GHC.Types.Annotations import GHC.Types.CompleteMatch import GHC.Core.InstEnv import GHC.Core.FamInstEnv +import Data.IORef -------------------------------------------------------------------------------- -- The hard queries @@ -177,6 +178,8 @@ data UnitEnv = UnitEnv , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId) -- TODO: @fendor Docs + , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex) + -- TODO: @fendor Docs } ueEPS :: UnitEnv -> IO ExternalPackageState @@ -186,6 +189,7 @@ initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitE initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache eud <- initExternalUnitDatabaseCache + unit_index <- newIORef (initUnitIndex) return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug @@ -194,6 +198,7 @@ initUnitEnv cur_unit hug namever platform = do , ue_platform = platform , ue_namever = namever , ue_eud = eud + , ue_unit_index = unit_index } updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -14,18 +14,59 @@ module GHC.Unit.External.Database ( lookupExternalUnitDatabases, -- * UnitDatabase (..), + -- * + mergeDatabases, + validateDatabase, + UnitPrecedenceMap, + sortByPreference, + compareByPreference, + -- * + UnitDbConfig(..), + readOrGetUnitDatabase, + readUnitDatabases, + readUnitDatabase, + getUnitDbRefs, + resolveUnitDatabase, + -- * + matchingStr, + matchingId, + matching, ) where import GHC.Prelude -import GHC.Data.OsPath -import GHC.Unit.Info -import GHC.Utils.Outputable +import GHC.Driver.DynFlags -import Data.IORef (IORef) +import Control.Monad +import Data.Char +import Data.Graph (SCC (..), stronglyConnComp) +import Data.IORef import Data.IORef qualified as IORef -import Data.Map.Strict +import Data.List (partition, sortBy) +import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Ord +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST +import GHC.Platform.ArchOS +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Validate +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import System.Directory +import System.Environment (getEnv) +import System.FilePath as FilePath -- ---------------------------------------------------------------------------- -- ExternalUnitDatabaseCache @@ -102,3 +143,422 @@ data UnitDatabase unit = UnitDatabase instance (Outputable u) => Outputable (UnitDatabase u) where ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each unit, a mapping from uid -> i indicates that this +-- unit was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- units that were defined later on the command line, if there +-- is an ambiguity. +type UnitPrecedenceMap = UniqMap UnitId Int + +-- | Given a list of databases, merge them together, where +-- units with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: Logger -> [UnitDatabase UnitId] + -> IO (UnitInfoMap, UnitPrecedenceMap) +mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] + where + merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do + debugTraceMsg logger 2 $ + text "loading package database" <+> ppr db_path + when (logVerbAtLeast logger 2) $ + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg logger 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set UnitId + override_set = Set.intersection (nonDetUniqMapToKeySet db_map) + (nonDetUniqMapToKeySet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: UnitInfoMap + pkg_map' = pkg_map `plusUniqMap` db_map + + prec_map' :: UnitPrecedenceMap + prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) + +-- | Validates a database, removing unusable units from it +-- (this includes removing units that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken units (dangling dependencies) +-- 2. Remove all units that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all units which have deps with mismatching ABIs +-- +validateDatabase :: [IgnorePackageFlag] -> UnitInfoMap + -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) +validateDatabase flagsIgnored pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse flagsIgnored -- (unitConfigFlagsIgnored cfg) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids + ] + + -- Find broken units + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (nonDetEltsUniqMap pkg_map1) + (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive units + sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) + | pkg <- nonDetEltsUniqMap pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) + (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out units whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (nonDetEltsUniqMap pkg_map4) + (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + -- combine all unusables. The order is important for shadowing. + -- plusUniqMapList folds using plusUFM which is right biased (opposite of + -- Data.Map.union) so the head of the list should be the least preferred + unusable = plusUniqMapList [ unusable_shadowed + , unusable_cyclic + , unusable_broken + , unusable_ignored + , directly_ignored + ] + + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the units +-- in later unit database. +compareByPreference + :: UnitPrecedenceMap + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + = case comparing unitPackageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) + , Just prec' <- lookupUniqMap prec_map (unitId pkg') + -- Prefer the unit from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + +-- ----------------------------------------------------------------------------- +-- Reading the unit database(s) + +data UnitDbConfig = UnitDbConfig + { unitDbConfigFlagsDB :: [PackageDBFlag] + , unitDbConfigProgramName :: String + , unitDbConfigDBName :: FilePath + , unitDbConfigPlatformArchOS :: ArchOS + , unitDbConfigGlobalDB :: FilePath + , unitDbConfigGHCDir :: FilePath + , unitDbConfigDBCache :: ExternalUnitDatabaseCache UnitId + } + +readUnitDatabases :: Logger -> UnitDbConfig -> IO [UnitDatabase UnitId] +readUnitDatabases logger cfg = do + conf_refs <- getUnitDbRefs cfg + confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs + mapM (readOrGetUnitDatabase logger cfg) confs + + +getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef] +getUnitDbRefs cfg = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (unitDbConfigProgramName cfg) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | Just (xs, x) <- snocView path, isSearchPathSeparator x + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs + | otherwise + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (unitDbConfigFlagsDB cfg)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolveUnitDatabase :: UnitDbConfig -> PkgDbRef -> IO (Maybe OsPath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitDbConfigGlobalDB cfg +resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do + dir <- versionedAppDir (unitDbConfigProgramName cfg) (unitDbConfigPlatformArchOS cfg) + let pkgconf = dir </> unitDbConfigDBName cfg + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero +resolveUnitDatabase _ (PkgDbPath name) = return $ Just name + +-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. +readOrGetUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readOrGetUnitDatabase logger cfg conf_file = + readExternalUnitDatabase (unitDbConfigDBCache cfg) conf_file >>= \ case + Nothing -> do + new_db <- readUnitDatabase logger cfg conf_file + cacheExternalUnitDatabase (unitDbConfigDBCache cfg) new_db + pure new_db + Just db -> + pure db + +-- | Read the 'UnitDatabase' at the given location. +readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readUnitDatabase logger cfg conf_file = do + isdir <- OsPath.doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- OsPath.doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ show conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ show conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = OsPath.dropTrailingPathSeparator conf_file + top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg) + pkgroot = OsPath.takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) + proto_pkg_configs + -- + pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 + return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 + where + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") + cache_exists <- OsPath.doesFileExist filename + if cache_exists + then do + debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg logger 2 $ text "There is no package.cache in" + <+> ppr conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) + <$> OsPath.getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg logger 3 $ text "There are no .conf files in" + <+> ppr conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ show conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" + direxists <- OsPath.doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +mungeUnitInfo :: OsPath -> OsPath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeBytecodeLibFields + . mungeLibDirFields + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) + +mungeLibDirFields :: UnitInfo -> UnitInfo +mungeLibDirFields pkg = + pkg { + unitLibraryDynDirs = case unitLibraryDynDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- | Default to using library-dirs if bytecode library dirs is not explicitly set. +mungeBytecodeLibFields :: UnitInfo -> UnitInfo +mungeBytecodeLibFields pkg = + pkg { + unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'UnitId' to +-- the 'UnitId's which have a dependency on it. +type RevIndex = UniqMap UnitId [UnitId] + +-- | Compute the reverse dependency index of a unit database. +reverseDeps :: UnitInfoMap -> RevIndex +reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db + where + go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex + go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) + go' from r to = addToUniqMap_C (++) r to [from] + +-- | Given a list of 'UnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those units, plus any units which depend on them. +-- Returns the pruned database, as well as a list of 'UnitInfo's +-- that was removed. +removeUnits :: [UnitId] -> RevIndex + -> UnitInfoMap + -> (UnitInfoMap, [UnitInfo]) +removeUnits uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- lookupUniqMap m uid + = case lookupUniqMap index uid of + Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' +-- which correspond to units that do not exist in the index. +depsNotAvailable :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in +-- 'unitAbiDepends' which correspond to units that do not exist, OR have +-- mismatching ABIs. +depsAbiMismatch :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- lookupUniqMap pkg_map dep_uid + = unitAbiHash dep_pkg == abi + | otherwise + = False + +-- ----------------------------------------------------------------------------- +-- Ignore units + +ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits +ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing unit is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> UnitInfo -> Bool +matchingStr str p + = str == unitPackageIdString p + || str == unitPackageNameString p + +matchingId :: UnitId -> UnitInfo -> Bool +matchingId uid p = uid == unitId p + +matching :: PackageArg -> UnitInfo -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case ===================================== compiler/GHC/Unit/External/Index.hs ===================================== @@ -0,0 +1,189 @@ +module GHC.Unit.External.Index ( + -- * + UnitIndex, + initUnitIndex, + wiringMap, + unwiringMap, + globalUnits, + setWireMap, + isWireMapEmpty, + addUnitInfoMap, + + -- * + GlobalUnitInfoMap, + lookupGlobalUnitInfoMap, + mkGlobalUnitKey, + + -- * + GlobalUnitKey, + globalUnitKeyFromUnitInfo, + + -- * + updateWiredInUnits, + updateWiredInUnitsInUnitInfo, + upd_wired_in_mod, +) where + +import GHC.Prelude + +import GHC.Data.ShortText qualified as ST +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Wired +import GHC.Unit.Info +import GHC.Unit.Types + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.Utils.Misc + +-- ---------------------------------------------------------------------------- +-- UnitIndex +-- ---------------------------------------------------------------------------- + +data UnitIndex = UnitIndex + { ui_wireMap :: !WiringMap + -- ^ A mapping from database unit keys to wired in unit ids. + , ui_unwireMap :: !UnwiringMap + -- ^ A mapping from wired in unit ids to unit keys from the database. + , ui_unitInfoMap :: !GlobalUnitInfoMap + -- ^ TODO @fendor: document + } + +wiringMap :: UnitIndex -> UnwiringMap +wiringMap = ui_unwireMap + +unwiringMap :: UnitIndex -> WiringMap +unwiringMap = ui_wireMap + +globalUnits :: UnitIndex -> GlobalUnitInfoMap +globalUnits = ui_unitInfoMap + +initUnitIndex :: UnitIndex +initUnitIndex = UnitIndex + { ui_wireMap = emptyUniqMap + , ui_unwireMap = emptyUniqMap + , ui_unitInfoMap = emptyUniqMap + } + +setWireMap :: WiringMap -> UnitIndex -> UnitIndex +setWireMap wired_map unit_index = + unit_index + { ui_wireMap = wired_map + , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + } + +isWireMapEmpty :: UnitIndex -> Bool +isWireMapEmpty unit_index = + isNullUniqMap (ui_wireMap unit_index) + +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex +addUnitInfoMap unit_info_map unit_index = + unit_index + { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index) + } + where + globalMap :: GlobalUnitInfoMap + globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map + +-- ---------------------------------------------------------------------------- +-- GlobalUnitInfoMap +-- ---------------------------------------------------------------------------- + +type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo) + +lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo +lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap = + case lookupUniqMap globalMap uid of + Nothing -> Nothing + Just sameUnitId -> Map.lookup abiHash sameUnitId + +mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap +mkGlobalUnitInfoMap unitInfos = + listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos + +-- ---------------------------------------------------------------------------- +-- GlobalUnitKey +-- ---------------------------------------------------------------------------- + +data GlobalUnitKey = + GlobalUnitKey + !UnitId -- ^ Unit Id of the 'UnitInfo' + !ST.ShortText + +globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey +globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui) + +mkGlobalUnitKey :: UnitId -> ST.ShortText -> GlobalUnitKey +mkGlobalUnitKey = GlobalUnitKey + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits wiredInMap knownInfos pkgs = + map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs + +updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = + let + upd_wired_in_pkg wiredInUnitId pkg = + pkg { unitId = wiredInUnitId + , unitInstanceOf = wiredInUnitId + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About units] in GHC.Unit + } + + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (unitExposedModules pkg) + } + in + case lookupUniqMap wiredInMap (unitId pkg) of + Just wiredIn -> + case lookupGlobalUnitInfoMap (mkGlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + +-- Helper functions for rewiring Module and Unit. These +-- rewrite Units of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in GHC.Builtin.Names. + +upd_wired_in_mod :: WiringMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiringMap -> Unit -> Unit +upd_wired_in_uid wiredInMap u = case u of + HoleUnit -> HoleUnit + RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) + VirtUnit indef_uid -> + VirtUnit $ mkInstantiatedUnit + (instUnitInstanceOf indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) + +upd_wired_in :: WiringMap -> UnitId -> UnitId +upd_wired_in wiredInMap key + | Just key' <- lookupUniqMap wiredInMap key = key' + | otherwise = key ===================================== compiler/GHC/Unit/External/ModuleOrigin.hs ===================================== @@ -0,0 +1,110 @@ +module GHC.Unit.External.ModuleOrigin ( + ModuleOrigin(..), + fromExposedModules, + fromReexportedModules, + fromFlag, + originVisible, + originEmpty, +) where + +import GHC.Prelude +import GHC.Unit.External.Validate +import GHC.Unit.Info +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Data.Semigroup as Semigroup + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + + -- | Module is unavailable because the unit is unusable. + | ModUnusable !UnusableUnit + + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigUnit :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . mkUnit) rhs)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + g Nothing x = x + g x Nothing = x + + x <> y = pprPanic "ModOrigin: module origin mismatch" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False ===================================== compiler/GHC/Unit/External/Providers.hs ===================================== @@ -0,0 +1,32 @@ +module GHC.Unit.External.Providers ( + ModuleNameProvidersMap, + pprModuleMap, +) where + +import GHC.Prelude + +import GHC.Types.Unique.Map +import GHC.Unit.Module +import GHC.Unit.External.ModuleOrigin +import GHC.Utils.Error +import GHC.Utils.Outputable + +-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and +-- its 'ModuleOrigin'). +-- +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one +-- origin for a given 'Module' + +type ModuleNameProvidersMap = + UniqMap ModuleName (UniqMap Module ModuleOrigin) + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleNameProvidersMap -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (nonDetUniqMapToList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) ===================================== compiler/GHC/Unit/External/Validate.hs ===================================== @@ -0,0 +1,79 @@ +module GHC.Unit.External.Validate ( + UnusableUnits, + reportUnusable, + + UnusableUnit(..), + + UnusableUnitReason(..), + pprReason, +) where + +import GHC.Prelude + +import GHC.Unit.Types +import GHC.Types.Unique.Map +import GHC.Unit.Info +import GHC.Utils.Outputable +import GHC.Utils.Logger +import Control.Monad +import GHC.Utils.Error + +type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) + +-- | A unusable unit module origin +data UnusableUnit = UnusableUnit + { uuUnit :: !Unit -- ^ Unusable unit + , uuReason :: !UnusableUnitReason -- ^ Reason + , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? + } + +-- | The reason why a unit is unusable. +data UnusableUnitReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This unit transitively depends on a unit that was never present + -- in any of the provided databases. + | BrokenDependencies [UnitId] + -- | This unit transitively depends on a unit involved in a cycle. + -- Note that the list of 'UnitId' reports the direct dependencies + -- of this unit that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [UnitId] + -- | This unit transitively depends on a unit which was ignored. + | IgnoredDependencies [UnitId] + -- | This unit transitively depends on a unit which was + -- shadowed by an ABI-incompatible unit. + | ShadowedDependencies [UnitId] + +instance Outputable UnusableUnitReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +pprReason :: SDoc -> UnusableUnitReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedDependencies deps -> + pref <+> text "unusable due to shadowed dependencies:" $$ + nest 2 (hsep (map ppr deps)) + +reportUnusable :: Logger -> UnusableUnits -> IO () +reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg logger 2 $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason ===================================== compiler/GHC/Unit/External/Visibility.hs ===================================== @@ -0,0 +1,72 @@ +module GHC.Unit.External.Visibility ( + VisibilityMap, + UnitVisibility(..), +) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Driver.DynFlags +import GHC.Types.Unique.Map +import GHC.Unit.Module +import GHC.Utils.Outputable as Outputable + +import Control.Applicative +import Data.Monoid (First (..)) +import Data.Semigroup qualified as Semigroup +import Data.Set (Set) +import Data.Set qualified as Set + +-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. +type VisibilityMap = UniqMap Unit UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'Unit'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name associated with the 'Unit'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Maybe PackageArg + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) + , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 + } + +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = emptyUniqMap + , uv_explicit = Nothing + } + mappend = (Semigroup.<>) + ===================================== compiler/GHC/Unit/External/Wired.hs ===================================== @@ -0,0 +1,143 @@ +module GHC.Unit.External.Wired ( + WiringMap, + UnwiringMap, + findWiredInUnits, +) where +import GHC.Types.Unique.Map +import GHC.Unit.Types + +import GHC.Prelude + +import GHC.Driver.DynFlags + +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Unit.Database +import GHC.Unit.Info +import GHC.Unit.Ppr +import GHC.Unit.Types +import GHC.Unit.Module +import GHC.Unit.Home + +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.DSet +import GHC.Types.Unique.Map +import GHC.Types.Unique +import GHC.Types.PkgQual + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe + +import System.Environment ( getEnv ) +import GHC.Data.FastString +import GHC.Data.OsPath ( OsPath ) +import qualified GHC.Data.OsPath as OsPath +import qualified GHC.Data.ShortText as ST +import GHC.Utils.Logger +import GHC.Utils.Error +import GHC.Utils.Exception + +import System.Directory +import System.FilePath as FilePath +import Control.Monad +import Data.Containers.ListUtils (nubOrd) +import Data.Graph (stronglyConnComp, SCC(..)) +import Data.Char ( toUpper ) +import Data.List ( intersperse, partition, sortBy, sortOn, sort ) +import Data.Set (Set) +import Data.Monoid (First(..)) +import qualified Data.Semigroup as Semigroup +import qualified Data.Set as Set +import Control.Applicative +import GHC.Unit.External.Database +import Data.IORef +import Data.Either (partitionEithers) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Unit.External.Visibility + +type WiringMap = + UniqMap UnitId UnitId + +type UnwiringMap = + UniqMap UnitId UnitId + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +findWiredInUnits + :: Logger + -> UnitPrecedenceMap + -> [UnitInfo] -- database + -> VisibilityMap -- info on what units are visible + -- for wired in selection + -> IO WiringMap -- map from unit id to wired identity +findWiredInUnits logger prec_map pkgs vis_map = do + -- Now we must find our wired-in units, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in units] in GHC.Unit.Types + let + matches :: UnitInfo -> UnitId -> Bool + pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) + findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] + where + all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] + + try ps = case sortByPreference prec_map ps of + p:_ -> Just <$> pick p + _ -> pure Nothing + + notfound = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " not found." + return Nothing + pick :: UnitInfo -> IO (UnitId, UnitInfo) + pick pkg = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " mapped to " + <> ppr (unitId pkg) + return (wired_pkg, pkg) + + + mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + wiredInMap :: UniqMap UnitId UnitId + wiredInMap = listToUniqMap + [ (unitId realUnitInfo, wiredInUnitId) + | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs + , not (unitIsIndefinite realUnitInfo) + ] + + return wiredInMap ===================================== compiler/GHC/Unit/Info.hs ===================================== @@ -5,11 +5,14 @@ module GHC.Unit.Info ( GenericUnitInfo (..) , GenUnitInfo , UnitInfo + , UnitInfoMap , UnitKey (..) , UnitKeyInfo , mkUnitKeyInfo , mapUnitInfo , mkUnitPprInfo + , evaluateUnitInfo + , seqUnitInfo , mkUnit @@ -53,6 +56,8 @@ import Data.Containers.ListUtils (nubOrd) import Data.Version import Data.Bifunctor import Data.List (isPrefixOf, stripPrefix) +import GHC.Types.Unique.Map +import Control.Exception (evaluate) -- | Information about an installed unit @@ -73,6 +78,9 @@ type UnitKeyInfo = GenUnitInfo UnitKey -- UnitId) type UnitInfo = GenUnitInfo UnitId +-- TODO @fendor +type UnitInfoMap = UniqMap UnitId UnitInfo + -- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo` mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo mkUnitKeyInfo = mapGenericUnitInfo @@ -250,3 +258,21 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar expandTag t | null t = "" | otherwise = '_':t + +evaluateUnitInfo :: UnitInfo -> IO UnitInfo +evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) + +seqUnitInfo :: UnitInfo -> b -> b +seqUnitInfo ui b = + unitImportDirs ui `seqList` + unitIncludeDirs ui `seqList` + unitLibraryDirs ui `seqList` + unitLibraryBytecodeDirs ui `seqList` + unitExtDepFrameworkDirs ui `seq` + unitHaddockInterfaces ui `seq` + unitHaddockHTMLs ui `seqList` + unitLibraryDynDirs ui `seqList` + unitLibraryDirsStatic ui `seqList` + unitDepends ui `seqList` + unitExposedModules ui `seqList` + b ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -5,7 +5,7 @@ module GHC.Unit.State ( module GHC.Unit.Info, - UnitIndex(..), + UnitIndex, initUnitIndex, setWireMap, isWireMapEmpty, @@ -26,7 +26,6 @@ module GHC.Unit.State ( listUnitInfo, -- * Querying the package config - UnitInfoMap, lookupUnit, lookupUnit', unsafeLookupUnit, @@ -96,6 +95,14 @@ import GHC.Unit.Types import GHC.Unit.Module import GHC.Unit.Home +import GHC.Unit.External.Database +import GHC.Unit.External.Index +import GHC.Unit.External.Wired +import GHC.Unit.External.Visibility +import GHC.Unit.External.Validate +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Providers + import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique.DSet @@ -108,28 +115,19 @@ import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable import GHC.Data.Maybe -import System.Environment ( getEnv ) import GHC.Data.FastString -import GHC.Data.OsPath ( OsPath ) import qualified GHC.Data.OsPath as OsPath import qualified GHC.Data.ShortText as ST import GHC.Utils.Logger import GHC.Utils.Error -import GHC.Utils.Exception -import System.Directory -import System.FilePath as FilePath import Control.Monad import Data.Containers.ListUtils (nubOrd) -import Data.Graph (stronglyConnComp, SCC(..)) -import Data.Char ( toUpper ) +import Data.Graph (SCC(..)) import Data.List ( intersperse, partition, sortBy, sortOn, sort ) import Data.Set (Set) import Data.Monoid (First(..)) -import qualified Data.Semigroup as Semigroup import qualified Data.Set as Set -import Control.Applicative -import GHC.Unit.External.Database import Data.IORef import Data.Either (partitionEithers) @@ -177,162 +175,6 @@ import Data.Either (partitionEithers) -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. --- | Given a module name, there may be multiple ways it came into scope, --- possibly simultaneously. This data type tracks all the possible ways --- it could have come into scope. Warning: don't use the record functions, --- they're partial! -data ModuleOrigin = - -- | Module is hidden, and thus never will be available for import. - -- (But maybe the user didn't realize), so we'll still keep track - -- of these modules.) - ModHidden - - -- | Module is unavailable because the unit is unusable. - | ModUnusable !UnusableUnit - - -- | Module is public, and could have come from some places. - | ModOrigin { - -- | @Just False@ means that this module is in - -- someone's @exported-modules@ list, but that package is hidden; - -- @Just True@ means that it is available; @Nothing@ means neither - -- applies. - fromOrigUnit :: Maybe Bool - -- | Is the module available from a reexport of an exposed package? - -- There could be multiple. - , fromExposedReexport :: [UnitInfo] - -- | Is the module available from a reexport of a hidden package? - , fromHiddenReexport :: [UnitInfo] - -- | Did the module export come from a package flag? (ToDo: track - -- more information. - , fromPackageFlag :: Bool - } - --- | A unusable unit module origin -data UnusableUnit = UnusableUnit - { uuUnit :: !Unit -- ^ Unusable unit - , uuReason :: !UnusableUnitReason -- ^ Reason - , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? - } - -instance Outputable ModuleOrigin where - ppr ModHidden = text "hidden module" - ppr (ModUnusable _) = text "unusable module" - ppr (ModOrigin e res rhs f) = sep (punctuate comma ( - (case e of - Nothing -> [] - Just False -> [text "hidden package"] - Just True -> [text "exposed package"]) ++ - (if null res - then [] - else [text "reexport by" <+> - sep (map (ppr . mkUnit) res)]) ++ - (if null rhs - then [] - else [text "hidden reexport by" <+> - sep (map (ppr . mkUnit) rhs)]) ++ - (if f then [text "package flag"] else []) - )) - --- | Smart constructor for a module which is in @exposed-modules@. Takes --- as an argument whether or not the defining package is exposed. -fromExposedModules :: Bool -> ModuleOrigin -fromExposedModules e = ModOrigin (Just e) [] [] False - --- | Smart constructor for a module which is in @reexported-modules@. Takes --- as an argument whether or not the reexporting package is exposed, and --- also its 'UnitInfo'. -fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False - --- | Smart constructor for a module which was bound by a package flag. -fromFlag :: ModuleOrigin -fromFlag = ModOrigin Nothing [] [] True - -instance Semigroup ModuleOrigin where - x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = - ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') - where g (Just b) (Just b') - | b == b' = Just b - | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - g Nothing x = x - g x Nothing = x - - x <> y = pprPanic "ModOrigin: module origin mismatch" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - -instance Monoid ModuleOrigin where - mempty = ModOrigin Nothing [] [] False - mappend = (Semigroup.<>) - --- | Is the name from the import actually visible? (i.e. does it cause --- ambiguity, or is it only relevant when we're making suggestions?) -originVisible :: ModuleOrigin -> Bool -originVisible ModHidden = False -originVisible (ModUnusable _) = False -originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f - --- | Are there actually no providers for this module? This will never occur --- except when we're filtering based on package imports. -originEmpty :: ModuleOrigin -> Bool -originEmpty (ModOrigin Nothing [] [] False) = True -originEmpty _ = False - --- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. -type VisibilityMap = UniqMap Unit UnitVisibility - --- | 'UnitVisibility' records the various aspects of visibility of a particular --- 'Unit'. -data UnitVisibility = UnitVisibility - { uv_expose_all :: Bool - -- ^ Should all modules in exposed-modules should be dumped into scope? - , uv_renamings :: [(ModuleName, ModuleName)] - -- ^ Any custom renamings that should bring extra 'ModuleName's into - -- scope. - , uv_package_name :: First FastString - -- ^ The package name associated with the 'Unit'. This is used - -- to implement legacy behavior where @-package foo-0.1@ implicitly - -- hides any packages named @foo@ - , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) - -- ^ The signatures which are contributed to the requirements context - -- from this unit ID. - , uv_explicit :: Maybe PackageArg - -- ^ Whether or not this unit was explicitly brought into scope, - -- as opposed to implicitly via the 'exposed' fields in the - -- package database (when @-hide-all-packages@ is not passed.) - } - -instance Outputable UnitVisibility where - ppr (UnitVisibility { - uv_expose_all = b, - uv_renamings = rns, - uv_package_name = First mb_pn, - uv_requirements = reqs, - uv_explicit = explicit - }) = ppr (b, rns, mb_pn, reqs, explicit) - -instance Semigroup UnitVisibility where - uv1 <> uv2 - = UnitVisibility - { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 - , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 - , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) - , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) - , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 - } - -instance Monoid UnitVisibility where - mempty = UnitVisibility - { uv_expose_all = False - , uv_renamings = [] - , uv_package_name = First Nothing - , uv_requirements = emptyUniqMap - , uv_explicit = Nothing - } - mappend = (Semigroup.<>) - - -- | Unit configuration data UnitConfig = UnitConfig { unitConfigPlatformArchOS :: !ArchOS -- ^ Platform arch and OS @@ -357,9 +199,6 @@ data UnitConfig = UnitConfig , unitConfigHideAllPlugins :: !Bool -- ^ Hide all plugins units by default , unitConfigDBCache :: !(ExternalUnitDatabaseCache UnitId) - -- ^ Cache of databases to use, in the order they were specified on the - -- command line (later databases shadow earlier ones). - -- If Nothing, databases will be found using `unitConfigFlagsDB`. -- command-line flags , unitConfigFlagsDB :: [PackageDBFlag] -- ^ Unit databases flags @@ -423,58 +262,6 @@ initUnitConfig dflags cached_dbs home_units = offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p)) offsetPackageDb _ p = p - --- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and --- its 'ModuleOrigin'). --- --- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one --- origin for a given 'Module' - -type ModuleNameProvidersMap = - UniqMap ModuleName (UniqMap Module ModuleOrigin) - -data GlobalUnitKey = - GlobalUnitKey - UnitId -- ^ Unit Id of the 'UnitInfo' - ST.ShortText - -data UnitIndex = UnitIndex - { ui_wireMap :: WiringMap - -- ^ TODO @fendor: document global property - , ui_unwireMap :: UnwiringMap - -- ^ TODO @fendor: document global property - , ui_unitInfoMap :: UnitInfoMap - -- ^ TODO @fendor: This needs to be Map (UnitId, AbiHash) UnitInfo for absolut correctness - } - -initUnitIndex :: UnitIndex -initUnitIndex = UnitIndex - { ui_wireMap = emptyUniqMap - , ui_unwireMap = emptyUniqMap - , ui_unitInfoMap = emptyUniqMap - } - -setWireMap :: WiringMap -> UnitIndex -> UnitIndex -setWireMap wired_map unit_index = - unit_index - { ui_wireMap = wired_map - , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] - } - -isWireMapEmpty :: UnitIndex -> Bool -isWireMapEmpty unit_index = - isNullUniqMap (ui_wireMap unit_index) - -addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex -addUnitInfoMap unit_info_map unit_index = - unit_index - { ui_unitInfoMap = unit_info_map `plusUniqMap` ui_unitInfoMap unit_index - } - --- lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo --- lookupUnitInfoMap unit_index unit_id = --- lookupUniqMap (ui_unitInfoMap unit_index) unit_id - data UnitState = UnitState { -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted -- so that only valid units are here. 'UnitInfo' reflects @@ -495,12 +282,6 @@ data UnitState = UnitState { -- And also to resolve package qualifiers with the PackageImports extension. packageNameMap :: UniqFM PackageName UnitId, - -- -- | A mapping from database unit keys to wired in unit ids. - -- wireMap :: WiringMap, - - -- -- | A mapping from wired in unit ids to unit keys from the database. - -- unwireMap :: UnwiringMap, - -- | The units we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a unit -- is always mentioned before the units it depends on. @@ -555,8 +336,6 @@ emptyUnitState = UnitState { allowVirtualUnits = False } -type UnitInfoMap = UniqMap UnitId UnitInfo - -- | Find the unit we know about with the given unit, if any lookupUnit :: UnitState -> Unit -> Maybe UnitInfo lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) @@ -593,7 +372,6 @@ lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo lookupUnitId' db uid = lookupUniqMap db uid - -- | Looks up the given unit in the unit state, panicking if it is not found unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo unsafeLookupUnit state u = case lookupUnit state u of @@ -711,7 +489,7 @@ initUnits logger dflags unit_index cached_dbs home_units = do FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) - wireMap <- ui_wireMap <$> readIORef unit_index + wireMap <- wiringMap <$> readIORef unit_index let home_unit = mkHomeUnit wireMap (homeUnitId_ dflags) @@ -764,210 +542,6 @@ mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ = | otherwise -> DefiniteHomeUnit hu_id (Just (u, is)) --- ----------------------------------------------------------------------------- --- Reading the unit database(s) - -readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId] -readUnitDatabases logger cfg = do - conf_refs <- getUnitDbRefs cfg - confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs - mapM (readOrGetUnitDatabase logger cfg) confs - - -getUnitDbRefs :: UnitConfig -> IO [PkgDbRef] -getUnitDbRefs cfg = do - let system_conf_refs = [UserPkgDb, GlobalPkgDb] - - e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH") - let base_conf_refs = case e_pkg_path of - Left _ -> system_conf_refs - Right path - | Just (xs, x) <- snocView path, isSearchPathSeparator x - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs - | otherwise - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) - - -- Apply the package DB-related flags from the command line to get the - -- final list of package DBs. - -- - -- Notes on ordering: - -- * The list of flags is reversed (later ones first) - -- * We work with the package DB list in "left shadows right" order - -- * and finally reverse it at the end, to get "right shadows left" - -- - return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg)) - where - doFlag (PackageDB p) dbs = p : dbs - doFlag NoUserPackageDB dbs = filter isNotUser dbs - doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs - doFlag ClearPackageDBs _ = [] - - isNotUser UserPkgDb = False - isNotUser _ = True - - isNotGlobal GlobalPkgDb = False - isNotGlobal _ = True - --- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' --- when the user database filepath is expected but the latter doesn't exist. --- --- NB: This logic is reimplemented in Cabal, so if you change it, --- make sure you update Cabal. (Or, better yet, dump it in the --- compiler info so Cabal can use the info.) -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath) -resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg -resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do - dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg) - let pkgconf = dir </> unitConfigDBName cfg - exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero -resolveUnitDatabase _ (PkgDbPath name) = return $ Just name - --- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. -readOrGetUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readOrGetUnitDatabase logger cfg conf_file = - readExternalUnitDatabase (unitConfigDBCache cfg) conf_file >>= \ case - Nothing -> do - new_db <- readUnitDatabase logger cfg conf_file - cacheExternalUnitDatabase (unitConfigDBCache cfg) new_db - pure new_db - Just db -> - pure db - --- | Read the 'UnitDatabase' at the given location. -readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readUnitDatabase logger cfg conf_file = do - isdir <- OsPath.doesDirectoryExist conf_file - - proto_pkg_configs <- - if isdir - then readDirStyleUnitInfo conf_file - else do - isfile <- OsPath.doesFileExist conf_file - if isfile - then do - mpkgs <- tryReadOldFileStyleUnitInfo - case mpkgs of - Just pkgs -> return pkgs - Nothing -> throwGhcExceptionIO $ InstallationError $ - "ghc no longer supports single-file style package " ++ - "databases (" ++ show conf_file ++ - ") use 'ghc-pkg init' to create the database with " ++ - "the correct format." - else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ show conf_file - - let - -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = OsPath.dropTrailingPathSeparator conf_file - top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) - pkgroot = OsPath.takeDirectory conf_file' - pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) - proto_pkg_configs - -- - pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 - return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 - where - readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] - readDirStyleUnitInfo conf_dir = do - let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") - cache_exists <- OsPath.doesFileExist filename - if cache_exists - then do - debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename - readPackageDbForGhc filename - else do - -- If there is no package.cache file, we check if the database is not - -- empty by inspecting if the directory contains any .conf file. If it - -- does, something is wrong and we fail. Otherwise we assume that the - -- database is empty. - debugTraceMsg logger 2 $ text "There is no package.cache in" - <+> ppr conf_dir - <> text ", checking if the database is empty" - db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) - <$> OsPath.getDirectoryContents conf_dir - if db_empty - then do - debugTraceMsg logger 3 $ text "There are no .conf files in" - <+> ppr conf_dir <> text ", treating" - <+> text "package database as empty" - return [] - else - throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ show conf_dir ++ - " even though package database is not empty" - - - -- Single-file style package dbs have been deprecated for some time, but - -- it turns out that Cabal was using them in one place. So this is a - -- workaround to allow older Cabal versions to use this newer ghc. - -- We check if the file db contains just "[]" and if so, we look for a new - -- dir-style db in conf_file.d/, ie in a dir next to the given file. - -- We cannot just replace the file with a new dir style since Cabal still - -- assumes it's a file and tries to overwrite with 'writeFile'. - -- ghc-pkg also cooperates with this workaround. - tryReadOldFileStyleUnitInfo = do - content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" - if take 2 content == "[]" - then do - let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" - direxists <- OsPath.doesDirectoryExist conf_dir - if direxists - then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) - liftM Just (readDirStyleUnitInfo conf_dir) - else return (Just []) -- ghc-pkg will create it when it's updated - else return Nothing - -mungeUnitInfo :: OsPath -> OsPath - -> UnitInfo -> UnitInfo -mungeUnitInfo top_dir pkgroot = - mungeBytecodeLibFields - . mungeLibDirFields - . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) - -mungeLibDirFields :: UnitInfo -> UnitInfo -mungeLibDirFields pkg = - pkg { - unitLibraryDynDirs = case unitLibraryDynDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - --- | Default to using library-dirs if bytecode library dirs is not explicitly set. -mungeBytecodeLibFields :: UnitInfo -> UnitInfo -mungeBytecodeLibFields pkg = - pkg { - unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - -evaluateUnitInfo :: UnitInfo -> IO UnitInfo -evaluateUnitInfo ui = do - importDirs <- evaluate $ unitImportDirs ui - includeDirs <- evaluate $ unitIncludeDirs ui - libraryDirs <- evaluate $ unitLibraryDirs ui - libraryBytecodeDirs <- evaluate $ unitLibraryBytecodeDirs ui - extDepFrameworkDirs <- evaluate $ unitExtDepFrameworkDirs ui - haddockInterfaces <- evaluate $ unitHaddockInterfaces ui - haddockHTMLs <- evaluate $ unitHaddockHTMLs ui - libraryDynDirs <- evaluate $ unitLibraryDynDirs ui - libraryDirsStatic <- evaluate $ unitLibraryDirsStatic ui - evaluate ui - { unitImportDirs = importDirs - , unitIncludeDirs = includeDirs - , unitLibraryDirs = libraryDirs - , unitLibraryDynDirs = libraryDynDirs - , unitLibraryDirsStatic = libraryDirsStatic - , unitLibraryBytecodeDirs = libraryBytecodeDirs - , unitExtDepFrameworkDirs = extDepFrameworkDirs - , unitHaddockInterfaces = haddockInterfaces - , unitHaddockHTMLs = haddockHTMLs - } - -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. @@ -1134,57 +708,6 @@ renameUnitInfo pkg_map insts conf = (unitExposedModules conf) } - --- A package named on the command line can either include the --- version, or just the name if it is unambiguous. -matchingStr :: String -> UnitInfo -> Bool -matchingStr str p - = str == unitPackageIdString p - || str == unitPackageNameString p - -matchingId :: UnitId -> UnitInfo -> Bool -matchingId uid p = uid == unitId p - -matching :: PackageArg -> UnitInfo -> Bool -matching (PackageArg str) = matchingStr str -matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid -matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case - --- | This sorts a list of packages, putting "preferred" packages first. --- See 'compareByPreference' for the semantics of "preference". -sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] -sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) - --- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking --- which should be "active". Here is the order of preference: --- --- 1. First, prefer the latest version --- 2. If the versions are the same, prefer the package that --- came in the latest package database. --- --- Pursuant to #12518, we could change this policy to, for example, remove --- the version preference, meaning that we would always prefer the units --- in later unit database. -compareByPreference - :: UnitPrecedenceMap - -> UnitInfo - -> UnitInfo - -> Ordering -compareByPreference prec_map pkg pkg' - = case comparing unitPackageVersion pkg pkg' of - GT -> GT - EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) - , Just prec' <- lookupUniqMap prec_map (unitId pkg') - -- Prefer the unit from the later DB flag (i.e., higher - -- precedence) - -> compare prec prec' - | otherwise - -> EQ - LT -> LT - -comparing :: Ord a => (t -> a) -> t -> t -> Ordering -comparing f a b = f a `compare` f b - pprFlag :: PackageFlag -> SDoc pprFlag flag = case flag of HidePackage p -> text "-hide-package " <> text p @@ -1195,143 +718,6 @@ pprTrustFlag flag = case flag of TrustPackage p -> text "-trust " <> text p DistrustPackage p -> text "-distrust " <> text p --- ----------------------------------------------------------------------------- --- Wired-in units --- --- See Note [Wired-in units] in GHC.Unit.Types - -type WiringMap = UniqMap UnitId UnitId -type UnwiringMap = UniqMap UnitId UnitId - -findWiredInUnits - :: Logger - -> UnitPrecedenceMap - -> [UnitInfo] -- database - -> VisibilityMap -- info on what units are visible - -- for wired in selection - -> IO WiringMap -- map from unit id to wired identity -findWiredInUnits logger prec_map pkgs vis_map = do - -- Now we must find our wired-in units, and rename them to - -- their canonical names (eg. base-1.0 ==> base), as described - -- in Note [Wired-in units] in GHC.Unit.Types - let - matches :: UnitInfo -> UnitId -> Bool - pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) - - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. - -- - -- When choosing which package to map to a wired-in package - -- name, we try to pick the latest version of exposed packages. - -- However, if there are no exposed wired in packages available - -- (e.g. -hide-all-packages was used), we can't bail: we *have* - -- to assign a package for the wired-in package: so we try again - -- with hidden packages included to (and pick the latest - -- version). - -- - -- You can also override the default choice by using -ignore-package: - -- this works even when there is no exposed wired in package - -- available. - -- - findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) - findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] - where - all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] - - try ps = case sortByPreference prec_map ps of - p:_ -> Just <$> pick p - _ -> pure Nothing - - notfound = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " not found." - return Nothing - pick :: UnitInfo -> IO (UnitId, UnitInfo) - pick pkg = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " mapped to " - <> ppr (unitId pkg) - return (wired_pkg, pkg) - - - mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds - let - wired_in_pkgs = catMaybes mb_wired_in_pkgs - - wiredInMap :: UniqMap UnitId UnitId - wiredInMap = listToUniqMap - [ (unitId realUnitInfo, wiredInUnitId) - | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs - , not (unitIsIndefinite realUnitInfo) - ] - - return wiredInMap - -updateWiredInUnits :: WiringMap -> UnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] -updateWiredInUnits wiredInMap knownInfos pkgs = - map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs - -updateWiredInUnitsInUnitInfo :: WiringMap -> UnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo -updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = - let - upd_pkg pkg - | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg) - = pkg { unitId = wiredInUnitId - , unitInstanceOf = wiredInUnitId - -- every non instantiated unit is an instance of - -- itself (required by Backpack...) - -- - -- See Note [About units] in GHC.Unit - } - | otherwise - = pkg - upd_deps pkg = pkg { - unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), - unitExposedModules - = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) - (unitExposedModules pkg) - } - in - case lookupUniqMap knownInfos (unitId pkg) of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps $ upd_pkg pkg - in - Left updated_pkg - --- Helper functions for rewiring Module and Unit. These --- rewrite Units of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. --- --- For instance, base-4.9.0.0 will be rewritten to just base, to match --- what appears in GHC.Builtin.Names. - -upd_wired_in_mod :: WiringMap -> Module -> Module -upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m - -upd_wired_in_uid :: WiringMap -> Unit -> Unit -upd_wired_in_uid wiredInMap u = case u of - HoleUnit -> HoleUnit - RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) - VirtUnit indef_uid -> - VirtUnit $ mkInstantiatedUnit - (instUnitInstanceOf indef_uid) - (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) - -upd_wired_in :: WiringMap -> UnitId -> UnitId -upd_wired_in wiredInMap key - | Just key' <- lookupUniqMap wiredInMap key = key' - | otherwise = key - updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap) where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of @@ -1341,51 +727,6 @@ updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList w -- ---------------------------------------------------------------------------- --- | The reason why a unit is unusable. -data UnusableUnitReason - = -- | We ignored it explicitly using @-ignore-package@. - IgnoredWithFlag - -- | This unit transitively depends on a unit that was never present - -- in any of the provided databases. - | BrokenDependencies [UnitId] - -- | This unit transitively depends on a unit involved in a cycle. - -- Note that the list of 'UnitId' reports the direct dependencies - -- of this unit that (transitively) depended on the cycle, and not - -- the actual cycle itself (which we report separately at high verbosity.) - | CyclicDependencies [UnitId] - -- | This unit transitively depends on a unit which was ignored. - | IgnoredDependencies [UnitId] - -- | This unit transitively depends on a unit which was - -- shadowed by an ABI-incompatible unit. - | ShadowedDependencies [UnitId] - -instance Outputable UnusableUnitReason where - ppr IgnoredWithFlag = text "[ignored with flag]" - ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) - ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) - ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) - ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) - -type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) - -pprReason :: SDoc -> UnusableUnitReason -> SDoc -pprReason pref reason = case reason of - IgnoredWithFlag -> - pref <+> text "ignored due to an -ignore-package flag" - BrokenDependencies deps -> - pref <+> text "unusable due to missing dependencies:" $$ - nest 2 (hsep (map ppr deps)) - CyclicDependencies deps -> - pref <+> text "unusable due to cyclic dependencies:" $$ - nest 2 (hsep (map ppr deps)) - IgnoredDependencies deps -> - pref <+> text ("unusable because the -ignore-package flag was used to " ++ - "ignore at least one of its dependencies:") $$ - nest 2 (hsep (map ppr deps)) - ShadowedDependencies deps -> - pref <+> text "unusable due to shadowed dependencies:" $$ - nest 2 (hsep (map ppr deps)) - reportCycles :: Logger -> [SCC UnitInfo] -> IO () reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs where @@ -1395,193 +736,6 @@ reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs text "these packages are involved in a cycle:" $$ nest 2 (hsep (map (ppr . unitId) vs)) -reportUnusable :: Logger -> UnusableUnits -> IO () -reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) - where - report (ipid, (_, reason)) = - debugTraceMsg logger 2 $ - pprReason - (text "package" <+> ppr ipid <+> text "is") reason - --- ---------------------------------------------------------------------------- --- --- Utilities on the database --- - --- | A reverse dependency index, mapping an 'UnitId' to --- the 'UnitId's which have a dependency on it. -type RevIndex = UniqMap UnitId [UnitId] - --- | Compute the reverse dependency index of a unit database. -reverseDeps :: UnitInfoMap -> RevIndex -reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db - where - go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex - go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) - go' from r to = addToUniqMap_C (++) r to [from] - --- | Given a list of 'UnitId's to remove, a database, --- and a reverse dependency index (as computed by 'reverseDeps'), --- remove those units, plus any units which depend on them. --- Returns the pruned database, as well as a list of 'UnitInfo's --- that was removed. -removeUnits :: [UnitId] -> RevIndex - -> UnitInfoMap - -> (UnitInfoMap, [UnitInfo]) -removeUnits uids index m = go uids (m,[]) - where - go [] (m,pkgs) = (m,pkgs) - go (uid:uids) (m,pkgs) - | Just pkg <- lookupUniqMap m uid - = case lookupUniqMap index uid of - Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) - Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) - | otherwise - = go uids (m,pkgs) - --- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' --- which correspond to units that do not exist in the index. -depsNotAvailable :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) - --- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in --- 'unitAbiDepends' which correspond to units that do not exist, OR have --- mismatching ABIs. -depsAbiMismatch :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg - where - abiMatch (dep_uid, abi) - | Just dep_pkg <- lookupUniqMap pkg_map dep_uid - = unitAbiHash dep_pkg == abi - | otherwise - = False - --- ----------------------------------------------------------------------------- --- Ignore units - -ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits -ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) - where - doit (IgnorePackage str) = - case partition (matchingStr str) pkgs of - (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) - | p <- ps ] - -- missing unit is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. - --- ---------------------------------------------------------------------------- --- --- Merging databases --- - --- | For each unit, a mapping from uid -> i indicates that this --- unit was brought into GHC by the ith @-package-db@ flag on --- the command line. We use this mapping to make sure we prefer --- units that were defined later on the command line, if there --- is an ambiguity. -type UnitPrecedenceMap = UniqMap UnitId Int - --- | Given a list of databases, merge them together, where --- units with the same unit id in later databases override --- earlier ones. This does NOT check if the resulting database --- makes sense (that's done by 'validateDatabase'). -mergeDatabases :: Logger -> [UnitDatabase UnitId] - -> IO (UnitInfoMap, UnitPrecedenceMap) -mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] - where - merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do - debugTraceMsg logger 2 $ - text "loading package database" <+> ppr db_path - when (logVerbAtLeast logger 2) $ - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg logger 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" - return (pkg_map', prec_map') - where - db_map = mk_pkg_map db - mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) - - -- The set of UnitIds which appear in both db and pkgs. These are the - -- ones that get overridden. Compute this just to give some - -- helpful debug messages at -v2 - override_set :: Set UnitId - override_set = Set.intersection (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) - - -- Now merge the sets together (NB: in case of duplicate, - -- first argument preferred) - pkg_map' :: UnitInfoMap - pkg_map' = pkg_map `plusUniqMap` db_map - - prec_map' :: UnitPrecedenceMap - prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) - --- | Validates a database, removing unusable units from it --- (this includes removing units that the user has explicitly --- ignored.) Our general strategy: --- --- 1. Remove all broken units (dangling dependencies) --- 2. Remove all units that are cyclic --- 3. Apply ignore flags --- 4. Remove all units which have deps with mismatching ABIs --- -validateDatabase :: UnitConfig -> UnitInfoMap - -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) -validateDatabase cfg pkg_map1 = - (pkg_map5, unusable, sccs) - where - ignore_flags = reverse (unitConfigFlagsIgnored cfg) - - -- Compute the reverse dependency index - index = reverseDeps pkg_map1 - - -- Helper function - mk_unusable mk_err dep_matcher m uids = - listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) - | pkg <- uids - ] - - -- Find broken units - directly_broken = filter (not . null . depsNotAvailable pkg_map1) - (nonDetEltsUniqMap pkg_map1) - (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 - unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken - - -- Find recursive units - sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) - | pkg <- nonDetEltsUniqMap pkg_map2 ] - getCyclicSCC (CyclicSCC vs) = map unitId vs - getCyclicSCC (AcyclicSCC _) = [] - (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 - unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic - - -- Apply ignore flags - directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) - (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 - unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored - - -- Knock out units whose dependencies don't agree with ABI - -- (i.e., got invalidated due to shadowing) - directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) - (nonDetEltsUniqMap pkg_map4) - (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 - unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed - - -- combine all unusables. The order is important for shadowing. - -- plusUniqMapList folds using plusUFM which is right biased (opposite of - -- Data.Map.union) so the head of the list should be the least preferred - unusable = plusUniqMapList [ unusable_shadowed - , unusable_cyclic - , unusable_broken - , unusable_ignored - , directly_ignored - ] -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our unit @@ -1646,7 +800,7 @@ mkUnitState logger unit_index cfg = do we build a mapping saying what every in scope module name points to. -} - raw_dbs <- readUnitDatabases logger cfg + raw_dbs <- readUnitDatabases logger (initUnitDbConfig cfg) -- distrust all units if the flag is set let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db) @@ -1669,14 +823,14 @@ mkUnitState logger unit_index cfg = do debugTraceMsg logger 2 $ text "package flags" <+> ppr other_flags - let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags + let !home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags -- Merge databases together, without checking validity (pkg_map1, prec_map) <- mergeDatabases logger dbs -- Now that we've merged everything together, prune out unusable -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + let (pkg_map2, unusable, sccs) = validateDatabase (unitConfigFlagsIgnored cfg) pkg_map1 reportCycles logger sccs reportUnusable logger unusable @@ -1725,12 +879,12 @@ mkUnitState logger unit_index cfg = do -- Note: we NEVER expose indefinite packages by -- default, because it's almost assuredly not -- what you want (no mix-in linking has occurred). - if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p + let !x = fsPackageName p in if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p then addToUniqMap vm (mkUnit p) UnitVisibility { uv_expose_all = True, uv_renamings = [], - uv_package_name = First (Just (fsPackageName p)), + uv_package_name = First (Just x), uv_requirements = emptyUniqMap, uv_explicit = Nothing } @@ -1760,9 +914,9 @@ mkUnitState logger unit_index cfg = do modifyIORef' unit_index (setWireMap wmap) pure wmap else do - pure $ ui_wireMap ui + pure $ wiringMap ui - let all_pkgs = updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1 + let all_pkgs = updateWiredInUnits wireMap (globalUnits ui) pkgs1 (new_pkgs, _pkgs_set) = partitionEithers all_pkgs modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs) pure (wireMap, map (either id id) all_pkgs) @@ -1853,13 +1007,22 @@ mkUnitState logger unit_index cfg = do , moduleNameProvidersMap = mod_map , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map , packageNameMap = pkgname_map - -- , wireMap = wired_map - -- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } return state +initUnitDbConfig :: UnitConfig -> UnitDbConfig +initUnitDbConfig uc = UnitDbConfig + { unitDbConfigFlagsDB = unitConfigFlagsDB uc + , unitDbConfigProgramName = unitConfigProgramName uc + , unitDbConfigDBName = unitConfigDBName uc + , unitDbConfigPlatformArchOS = unitConfigPlatformArchOS uc + , unitDbConfigGlobalDB = unitConfigGlobalDB uc + , unitDbConfigGHCDir = unitConfigGHCDir uc + , unitDbConfigDBCache = unitConfigDBCache uc + } + selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True selectHptFlag _ _ = False @@ -1872,12 +1035,11 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags -- MP: This does not yet support thinning/renaming go cur _ = cur - -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' -- that it was recorded as in the package database. unwireUnit :: UnitIndex -> Unit -> Unit unwireUnit state uid@(RealUnit (Definite def_uid)) = - maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid) + maybe uid (RealUnit . Definite) (lookupUniqMap (unwiringMap state) def_uid) unwireUnit _ uid = uid -- ----------------------------------------------------------------------------- @@ -2164,7 +1326,7 @@ lookupModuleWithSuggestions' pkgs mod_map name mb_pn suggestions = fuzzyLookup (moduleNameString name) all_mods all_mods :: [(String, ModuleSuggestion)] -- All modules - all_mods = sortBy (comparing fst) $ + all_mods = sortOn fst $ [ (moduleNameString m, suggestion) | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) @@ -2307,17 +1469,6 @@ pprUnitsSimple ue = pprUnitsWith pprIPI ue t = if isUnitInfoTrusted ue ipi then text "T" else text " " in e <> t <> text " " <> ftext i --- | Show the mapping of modules to where they come from. -pprModuleMap :: ModuleNameProvidersMap -> SDoc -pprModuleMap mod_map = - vcat (map pprLine (nonDetUniqMapToList mod_map)) - where - pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) - pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc - pprEntry m (m',o) - | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) - | otherwise = ppr m' <+> parens (ppr o) - fsPackageName :: UnitInfo -> FastString fsPackageName info = fs where ===================================== compiler/GHC/Unit/State.hs-boot ===================================== @@ -1,6 +1,3 @@ module GHC.Unit.State where data UnitState -data ModuleSuggestion -data ModuleOrigin -data UnusableUnit ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -578,7 +578,7 @@ had used @-ignore-package@). The affected packages are compiled with, e.g., @-this-unit-id base@, so that the symbols in the object files have the unversioned unit id in their name. -Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. +Make sure you change 'wiredInUnitIds' if you add an entry here. -} ===================================== compiler/ghc.cabal.in ===================================== @@ -968,6 +968,12 @@ Library GHC.Unit.Env GHC.Unit.External GHC.Unit.External.Database + GHC.Unit.External.Index + GHC.Unit.External.ModuleOrigin + GHC.Unit.External.Providers + GHC.Unit.External.Validate + GHC.Unit.External.Visibility + GHC.Unit.External.Wired GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home ===================================== ghc/GHCi/UI.hs ===================================== @@ -855,8 +855,9 @@ installInteractiveHomeUnits dflags = do setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv setupHomeUnitFor logger dflags all_home_units = do env <- GHC.getSession + let unit_index = hsc_unit_index env (unit_state,home_unit,_mconstants) <- - liftIO $ initUnits logger dflags (hscEUDC env) all_home_units + liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units hpt <- liftIO emptyHomePackageTable pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -746,11 +746,20 @@ mungeUnitInfoPaths top_dir pkgroot pkg = , unitHaddockHTMLs = munge_paths (munge_urls (unitHaddockHTMLs pkg)) } where - munge_paths = map munge_path - munge_urls = map munge_url + munge_paths = strictMap munge_path + munge_urls = strictMap munge_url (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot -- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. -- Prefer 'decodeUtf' and gracious error handling. unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath unsafeDecodeUtf = OsPath.Internal.so + +strictMap :: (a -> b) -> [a] -> [b] +strictMap _ [] = [] +strictMap f (x:xs) = + let + !x' = f x + !xs' = strictMap f xs + in + x' : xs' ===================================== utils/haddock/haddock-api/src/Haddock.hs ===================================== @@ -260,7 +260,9 @@ haddockWithGhc ghc args = handleTopExceptions $ do logger' <- getLogger let logger = setLogFlags logger' (initLogFlags dflags) let parserOpts = Parser.initParserOpts dflags - !unit_state <- hsc_units <$> getSession + env <- getSession + let !unit_state = hsc_units env + !unit_index <- liftIO $ hscUnitIndex env -- If any --show-interface was used, show the given interfaces forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do @@ -287,7 +289,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages ifaces + liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem packages ifaces -- If we were not given any input files, error if documentation was -- requested @@ -300,7 +302,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages [] + liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -356,6 +358,7 @@ renderStep :: DynFlags -> ParserOpts -> Logger + -> UnitIndex -> UnitState -> [Flag] -> SinceQual @@ -364,7 +367,7 @@ renderStep -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem pkgs interfaces = do +renderStep dflags parserOpts logger unit_index unit_state flags sinceQual nameQual concSem pkgs interfaces = do updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) -> ( case baseUrl flags of Nothing -> docPathsHtml docPath @@ -380,7 +383,7 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem (DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags parserOpts logger unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap + render dflags parserOpts logger unit_index unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap where -- get package name from unit-id packageName :: Unit -> String @@ -394,6 +397,7 @@ render :: DynFlags -> ParserOpts -> Logger + -> UnitIndex -> UnitState -> [Flag] -> SinceQual @@ -403,7 +407,7 @@ render -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO () -render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do +render dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do let packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty) $ optPackageName flags @@ -505,7 +509,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces p -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module - unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } + unwire m = m { moduleUnit = unwireUnit unit_index (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn' = hPutStrLn stderr . ("Warning: " ++) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/747315c39653ecf12f598554bc1258… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/747315c39653ecf12f598554bc1258… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/9.14.2-backports] 27 commits: Refactor GHC.Driver.Errors.printMessages
by Zubin (＠wz1000) 15 Jul '26

15 Jul '26

Zubin pushed to branch wip/9.14.2-backports at Glasgow Haskell Compiler / GHC Commits: c77b77e7 by Simon Hengel at 2026-07-15T16:39:36+05:30 Refactor GHC.Driver.Errors.printMessages (cherry picked from commit 49a44ab79d644590abdeff8699406bbd2d310715) - - - - - 704f7368 by Simon Hengel at 2026-07-15T16:40:59+05:30 Include the rendered message in -fdiagnostics-as-json output This implements #26173. (cherry picked from commit d046b5ab146167bcb86c675d101ff5e3c4eb8c8e) - - - - - 6850cb8f by fendor at 2026-07-15T16:41:10+05:30 Revert prog003 acceptance We thought the commit 286f1adff3e78d775ff325caff71d0cee25d710b fixed the test, but due to changes to ghci, modules loaded during the GHCi session, the test was actually no longer testing what it set out to do, "fixing" the broken test. As modules are added to the `interactive-session` home unit, the object code needs to be compiled with `-this-unit-id interactive-session`, otherwise the object code won't be used. Once this has been fixed in the test, the test fails as expected again. (cherry picked from commit 8f9917557a7ef290dfa8b913c3a4146289586ec6) - - - - - 41ecaadd by sheaf at 2026-07-15T16:44:19+05:30 Fix AArch64 clobbering bug for MUL2 On AArch64, the code generator could clobber one of the input operands when computing the lower bits of a MUL2 operation. This rendered invalid the subsequent computation of the high bits. This commit fixes that by using a temporary register. The register allocator can remove the redundant move in the common case when the registers do not conflict. Fixes #27046 (cherry picked from commit c9015f0953e72829e89ac768b6ad9ece34c7e187) - - - - - 985b0e36 by mangoiv at 2026-07-15T16:44:19+05:30 libraries/process: bump submodule to v1.6.30.0 - bump the submodule to the appropriate tag - suppress benign warning resulting from the change (cherry picked from commit d9ea2d76545452a7df567b162340079cb024a40c) - - - - - 16e9f578 by ARATA Mizuki at 2026-07-15T16:44:19+05:30 RISC-V NCG: Zero-extend the result of castFloatToWord32 According to the ISA manual, FMV.X.W sign-extends the result. We need to truncate the result to avoid creating an exotic Word32 value. Fixes #27300 (cherry picked from commit 291ce3aafe4ca3d2562154a28c595a858987d9f1) - - - - - c16871c9 by ARATA Mizuki at 2026-07-15T16:44:19+05:30 RISC-V NCG: Treat d28-d31 (ft8-ft11) as caller-saved According to the calling convention, the registers d28-d31 (ft8-ft11) are caller-saved. Fixes #27306 (cherry picked from commit 011be91fdaa7869dff2f30b8f2ecca3c9a713739) - - - - - d8f0999a by ARATA Mizuki at 2026-07-15T16:44:20+05:30 RISC-V NCG: Set rounding mode when emitting `truncate` If we omit the rounding mode for `fcvt`, `dyn` will be used. We do not want that for `truncate`, so we set `rtz`. In other places, we set `rne` because we do not use the dynamic rounding mode. Fixes #27303 (cherry picked from commit e8a547133031b7de8f6f9bbd70a7148eda0941ee) - - - - - bfcd8dfc by Zubin Duggal at 2026-07-15T16:44:20+05:30 rts: fix validate build with gcc 16. `__attribute__((regparm(1)))` is ignored on x86_64 and now gcc warns that it is ignored: rts/sm/Evac.h:35:1: error: error: ‘regparm’ attribute ignored [-Werror=attributes] See https://gcc.gnu.org/git/?p=gcc.git;a=commit;h=ccead81bbc39668376eb5cf47066a… Fixes #27366 (cherry picked from commit 9438bec7117433bbc70449d4288f6ee32dbbbec4) - - - - - 275a0382 by Ian Duncan at 2026-07-15T16:44:54+05:30 AArch64: use SXTH, not SXTW, for W32 signExtendReg signExtendReg was using SXTH (sign-extend halfword, 16-bit) for W32-to-W64 sign extension. This should be SXTW (sign-extend word, 32-bit). SXTH only sign-extends the lower 16 bits, producing wrong results for 32-bit values whose bit 15 differs from bit 31. Other fixes: - At sub-W64, code gen for MO_S_Mul2 should use W32 registers for SMULL source operands as per the ARM spec (SMULL Xd, Wn, Wm), and not W64. - Ensure signExtendReg uses the source width for the source operand in SXTW/SXTH/SXTB instructions. GNU as requires sxtw Xd,Wn (not sxtw Xd,Xn), while LLVM's integrated assembler on macOS is lenient. - Fix overflow flag computation for `MO_S_Mul2`. The overflow bit was exactly inverted for sub-W64 operands. Fixes #26978 and #27047 (cherry picked from commit 636c1c7ae47495f022affa501ea0a40cb55cd4a4) - - - - - dec52356 by Luite Stegeman at 2026-07-15T16:46:04+05:30 tag inference: don't confuse functions with their return values inferTagRhs was mixing up taggedness for closures and return values for function closures. We really shouldn't assign TagTuple to a properly tagged function returning a tuple. We fix this by keeping track of functions (TagFun) separately from values (TagVal) and keeping track of their return value. TagFun is also used for join points. fixes #27005 (cherry picked from commit 7fe4f2ec3ce12ea138177c81a019dcfc148fe5d4) - - - - - a40f21b5 by Sebastian Graf at 2026-07-15T16:47:03+05:30 Desugar a `case` scrutinee only once (#27383, #20251) In `dsExpr` for `HsCase` we desugared the scrutinee /twice/: once to build the Core `case` itself, and again inside `matchWrapper`, which re-desugared the source scrutinee (via `addHsScrutTmCs`) purely to record long-distance information for the pattern-match checker. For a single `case` that is merely wasteful. But for nested cases it is catastrophic. Consider case (case (case e of ... ) of ... ) of ... Desugaring the outer scrutinee desugars the middle `case` twice, each of which desugars the inner `case` twice, and so on. The work doubles at every level, so desugaring takes O(2^n) time in the nesting depth. That is the blowup reported in #27383; it is also what makes the machine-generated program in #20251 take an age to compile. The fix is simple. `matchWrapper` is handed the scrutinee anyway, so we give it the Core expression we have /already/ desugared, and record the long-distance term constraint with `addCoreScrutTmCs` instead of re-desugaring from source. This is just what `matchSinglePatVar` already does for single-pattern matches. So: * `matchWrapper` now takes `Maybe [CoreExpr]` rather than `Maybe [LHsExpr GhcTc]`. * The `HsCase` equation of `dsExpr` passes the already-desugared `core_discrim`; the arrow desugarer passes its match variables. * `addHsScrutTmCs` had no other use, so it is gone. Desugaring is now linear in the nesting depth. (The coverage checker still runs `simpleOptExpr` over each scrutinee, which leaves the total at O(n^2); that is ample.) The long-distance information itself is unchanged: the checker sees precisely the Core that backs the generated code. Test: deSugar/should_compile/T27383 (cherry picked from commit 67d41299be96798702377e6e2b826f9c8e070821) - - - - - 46dfc982 by mangoiv at 2026-07-15T16:48:09+05:30 ExplicitLevelImports: check staging for types just like for values Previously, imported types were entirely exempted from staging checks as the implicit stage persistance assumed to be all imported types to be well staged. ExplicitLevelImports' change specification, however, does not do such an exemption. Thus we want to introduce such a check, just like we have for values. ExplicitLevelImports does not, however, talk about local names - from its perspective, we could theoretically keep treating locally introduced types specially - e.g. an ill-staged used in a quote would only emit a warning, not an error. To allow for a potential future migration away from such wrinkles as the staging check in notFound (see Note [Out of scope might be a staging error]) we consistently do the strict staging check that we also do for value if ExplicitLevelImports is on. Closes #26098 (cherry picked from commit c64cca1ef667751c02ce2eb4141349e601aac99c) - - - - - 41ff5cd7 by Simon Hengel at 2026-07-15T16:48:47+05:30 Reference correct package in error messages for reexported modules (fixes #27417) (cherry picked from commit a805b2a25021606b30d250e084d4beecbfac0d0a) - - - - - 0088aeb5 by Luite Stegeman at 2026-07-15T16:49:09+05:30 rts: handle large AP closures in compacting GC The function update_fwd_large in the compacting GC could run into an unexpected object with the following error: internal error: update_fwd_large: unknown/strange object 24 Closure type 24 is the AP closure, which was not handled in upd_fwd_large. This patch adds handling them. fixes #27434 (cherry picked from commit cca0d58963f802a8b2e43aa2dbc58592f8ad07bb) - - - - - 3bbf347b by Cheng Shao at 2026-07-15T16:49:09+05:30 compiler: fix missing handling of CmmUnsafeForeignCall node in LayoutStack This patch fixes missing handling of `CmmUnsafeForeignCall` middle node in the `LayoutStack` pass. Before proc-points splitting, this pass computes liveliness of local registers, and spills those alive across a Cmm native call onto the stack. It need to traverse all middle nodes in each block and check whether a local register is an assignee, if so then the previous mapping in `sm_regs` is invalidated and needs to be dropped. However, it didn't handle `CmmUnsafeForeignCall` node which may also assign to a local register. When proc-points splitting is enabled, this can produce an invalid basic block that doesn't properly backup the updated local register to the stack before doing a Cmm call, resulting in completely invalid runtime behavior. The patch also adds a `T27447` regression test. With no-TNTC or with LLVM backend, without the fix the test case would output a stale 0x1111111111111111 value, instead of the expected 0x2222222222222222 output. Fixes #27447. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 3f00f234d0d5b3b3b2a23a5dc70ce372eb9bbdb4) - - - - - 06fcc414 by Cheng Shao at 2026-07-15T16:49:09+05:30 ci: use treeless fetch for perf notes This patch improves the ci logic for fetching perf notes by using treeless fetch (https://github.blog/open-source/git/get-up-to-speed-with-partial-clone-and-…) to avoid downloading all blobs of the perf notes repo at once, and only fetch the actually required blobs on-demand when needed. This makes the initial `test-metrics.sh pull` operation much faster, and also more robust, since we are seeing an increasing rate of 504 errors in CI when fetching all perf notes at once, which is a major source of CI flakiness at this point. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 3c0013778b4459c1f8e56cd0dc2600f5bb3769d2) - - - - - feaa0f47 by mangoiv at 2026-07-15T16:49:09+05:30 ci: retry fetching test metrics Retry fetching test metrics to make the CI not fail if the services is temporarily unavailable (cherry picked from commit b7e24044fde064cb3f0d44c36872a86d024cd7d4) - - - - - c19af18a by Zubin Duggal at 2026-07-15T16:49:09+05:30 Bump semaphore-compat submodule to 2.0.1 This versions includes some cruicial fixes for darwin (cherry picked from commit 4180af3f71754472dbd49b85179b25fd29bd9998) - - - - - 4e296572 by Zubin Duggal at 2026-07-15T16:49:09+05:30 CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent In #25924, we segfault because speculation forces a projection out of a RUBBISH dictionary (which we generated because it absent). Solution: Don't speculate on bindings we already know are absent. Fixes 25924 (cherry picked from commit 9b714c4c833461c621f0a050680848d7248aa57e) - - - - - 25026e53 by Zubin Duggal at 2026-07-15T16:49:55+05:30 Don't make absent fillers for terminating types In #25924 we discovered that we could speculatively evaluate an absent filler for a dictionary, and project a field (a superclass selector) out of it, resulting in segfaults. Solution: Never make an absent filler or rubbish literal for a terminating type like a dictionary. mkAbsentFiller returns Nothing for isTerminatingType, so worker/wrapper and the specialiser keep the real argument instead. Some small metric decreases because we do a little less work in the simplifier now. Metric Decrease: T9872a T9872b T9872c TcPlugin_RewritePerf (cherry picked from commit 4a59b3eece9b7106fcbe73d2d06a49755be4ea8f) - - - - - 588765fd by Andreas Klebinger at 2026-07-15T16:50:45+05:30 Fix a profiling race condition resulting in segfaults. StgToCmm: Don't assume tagged FUN closures in closureCodeBody. When entering a closure the self/node pointer might not be tagged in some situations when a thunk is evaluated by multiple threads. So we most AND away the tag bits rather than subtracting an expected tag. Apply.cmm: Fix a race condition occuring when a thunk is mutated during GC. In stg_ap_0_fast when might need to run GC before entering a thunk. If this happens another thread or the GC itself might mutate the closure making entering it no longer valid. We now check for this. Add test and changelog for #27123 fixes. (cherry picked from commit ed09895d7de1ca116a561868c151fd825a16ad0c) - - - - - e86a5193 by Cheng Shao at 2026-07-15T16:50:45+05:30 ghc-heap: fix invalid srtlen returned by peekItbl when no-TNTC This patch fixes the no-TNTC code path of `peekItbl` so that it looks at the right memory address when reading the `srt` field from the `StgInfoTable_` struct. Also adds a `T27465` regression test that reproduces the bug on no-TNTC builds before the fix. Fixes #27465. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 67c03eb2c762fdfeb646eb8345341173dd4268b2) - - - - - c603d701 by Cheng Shao at 2026-07-15T16:50:45+05:30 compiler: fix miscompiled %load_relaxed, add missing %store_relaxed This patch fixes the %load_relaxed cmm primop compilation logic to correctly use relaxed memory ordering, and adds the missing %store_relaxed primop. Parsing logic of %load/%store with explicit ordering is covered in the AtomicFetch test case. Fixes #27483. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit eee8ec5b25ef0f83ba4822e7a0a941df7b0bec5f) - - - - - acc488d1 by Cheng Shao at 2026-07-15T16:50:45+05:30 rts: fix missing UNTAG in stg_readTVarIOzh This patch fixes missing UNTAG on the current value closure read from StgTVar. UNTAG is a no-op when it's stg_TREC_HEADER_info which is word aligned; it may be a tagged closure, and reading info table from the tagged address is an unaligned load which may cause issues on platforms with strict alignment requirements. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit d377e83e51d39a06e1f0bf2e35a923a3210b21a2) - - - - - 4c16d073 by Cheng Shao at 2026-07-15T16:50:46+05:30 rts: fix missing UNTAG in stg_control0zh_ll This patch fixes missing UNTAG on the cont closure returned by captureContinuationAndAbort. In case it's not NULL, captureContinuationAndAbort returns a tagged StgContinuation closure, in which case it must be untagged before accessing the apply_mask_frame field. In the past it worked out of luck: when apply_mask_frame was NULL then mask_frame_offset is also 0 so the control flow didn't diverge to a wrong path. Still, this is horribly wrong and will crash once StgContinuation struct is refactored and fields are shuffled around. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 8ed038421a20e3e4e681973b2f5098e5bd2144b5) - - - - - 0906c7dc by Cheng Shao at 2026-07-15T16:50:46+05:30 compiler: fix redundant AP thunk codegen when not using -ticky-ap-thunk This patch fixes a double negation confusion in !7525 that results in some redundant AP thunk code generation when not using -ticky-ap-thunk. Now, we use `stgToCmmUseStdApThunk` to indicate whether precomputed AP thunks in the RTS should be used, which defaults to `True`, unless `-ticky-ap-thunk` is passed. `-finfo-table-map` now also implies `-ticky-ap-thunk`, since when doing IPE profiling we want the generated AP thunks to be unique. Fixes #27502. ------------------------- Metric Decrease: T3064 ------------------------- Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 5aa7000ae246ae6a706437799338295b5801a629) - - - - - 138 changed files: - .gitlab/test-metrics.sh - + changelog.d/T26978 - + changelog.d/T27046 - + changelog.d/T27047 - + changelog.d/T27123.md - + changelog.d/fix-absent-dict-projection - + changelog.d/fix-cmm-atomic-load-store - + changelog.d/fix-compacting-gc-ap-27434 - + changelog.d/fix-exponential-case-desugar-27383 - + changelog.d/fix-layout-stack-fcall - + changelog.d/fix-peekitbl-no-tntc - + changelog.d/fix-use-std-ap-thunk - + changelog.d/reexported-module-errors - changelog.d/semaphore-v2 - + changelog.d/tag-inference-27005 - compiler/GHC/Cmm/LayoutStack.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/RV64/CodeGen.hs - compiler/GHC/CmmToAsm/RV64/Instr.hs - compiler/GHC/CmmToAsm/RV64/Ppr.hs - compiler/GHC/CmmToAsm/RV64/Regs.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match.hs-boot - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/Iface/Errors.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Splice.hs-boot - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/EnforceEpt/Rewrite.hs - compiler/GHC/Stg/EnforceEpt/TagSig.hs - compiler/GHC/Stg/EnforceEpt/Types.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Literal.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Logger.hs - + docs/users_guide/9.14.2-notes.rst - + docs/users_guide/diagnostics-as-json-schema-1_2.json - docs/users_guide/release-notes.rst - docs/users_guide/using.rst - ghc/GHCi/UI/Exception.hs - hadrian/src/Settings/Warnings.hs - + libraries/ghc-heap/tests/T27465.hs - + libraries/ghc-heap/tests/T27465.stdout - libraries/ghc-heap/tests/all.T - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - libraries/process - libraries/semaphore-compat - rts/Apply.cmm - rts/ContinuationOps.cmm - rts/PrimOps.cmm - rts/sm/Compact.c - rts/sm/Evac.h - testsuite/driver/testlib.py - testsuite/tests/cmm/should_run/AtomicFetch.hs - testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm - + testsuite/tests/cmm/should_run/T27447.hs - + testsuite/tests/cmm/should_run/T27447.stdout - + testsuite/tests/cmm/should_run/T27447_cmm.cmm - testsuite/tests/cmm/should_run/all.T - + testsuite/tests/codeGen/should_gen_asm/aarch64-sxth-mul2.asm - + testsuite/tests/codeGen/should_gen_asm/aarch64-sxth-mul2.cmm - + testsuite/tests/codeGen/should_gen_asm/aarch64-sxtw.asm - + testsuite/tests/codeGen/should_gen_asm/aarch64-sxtw.cmm - testsuite/tests/codeGen/should_gen_asm/all.T - testsuite/tests/codeGen/should_run/T16617.hs - testsuite/tests/codeGen/should_run/T16617.stdout - + testsuite/tests/codeGen/should_run/T27046.hs - + testsuite/tests/codeGen/should_run/T27046_cmm.cmm - + testsuite/tests/codeGen/should_run/aarch64-sxtw-cmm.cmm - + testsuite/tests/codeGen/should_run/aarch64-sxtw-run.hs - + testsuite/tests/codeGen/should_run/aarch64-sxtw-run.stdout - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/core-to-stg/T14895.stderr - + testsuite/tests/core-to-stg/T25924/B.hs - + testsuite/tests/core-to-stg/T25924/Main.hs - + testsuite/tests/core-to-stg/T25924/all.T - + testsuite/tests/core-to-stg/T25924a.hs - + testsuite/tests/core-to-stg/T25924a.stdout - testsuite/tests/core-to-stg/all.T - + testsuite/tests/deSugar/should_compile/T27383.hs - testsuite/tests/deSugar/should_compile/all.T - testsuite/tests/dmdanal/should_compile/T18982.stderr - testsuite/tests/driver/json.stderr - testsuite/tests/driver/json_warn.stderr - testsuite/tests/ghci/prog003/prog003.T - testsuite/tests/ghci/prog003/prog003.script - + testsuite/tests/package/ImportReexport.hs - + testsuite/tests/package/ImportReexport.stderr - testsuite/tests/package/all.T - + testsuite/tests/rts/T27123.hs - + testsuite/tests/rts/T27434.hs - + testsuite/tests/rts/T27434.stdout - testsuite/tests/rts/all.T - testsuite/tests/simplCore/should_compile/T4201.stdout - + testsuite/tests/simplCore/should_run/T27005.hs - + testsuite/tests/simplCore/should_run/T27005.stdout - + testsuite/tests/simplCore/should_run/T27005_aux.hs - testsuite/tests/simplCore/should_run/all.T - testsuite/tests/simplStg/should_compile/T24806.hs - testsuite/tests/simplStg/should_compile/T24806.stderr - + testsuite/tests/simplStg/should_compile/T27005b.hs - + testsuite/tests/simplStg/should_compile/T27005b.stderr - testsuite/tests/simplStg/should_compile/all.T - testsuite/tests/simplStg/should_compile/inferTags004.hs - testsuite/tests/simplStg/should_compile/inferTags004.stderr - + testsuite/tests/simplStg/should_run/T27005a.hs - + testsuite/tests/simplStg/should_run/T27005a.stdout - testsuite/tests/simplStg/should_run/all.T - + testsuite/tests/th/T26098A_quote.hs - + testsuite/tests/th/T26098A_splice.hs - + testsuite/tests/th/T26098_local.hs - + testsuite/tests/th/T26098_local.stderr - + testsuite/tests/th/T26098_quote.hs - + testsuite/tests/th/T26098_quote.stderr - + testsuite/tests/th/T26098_splice.hs - + testsuite/tests/th/T26098_splice.stderr - testsuite/tests/th/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/08c99230c9e2e09afc500693aa716b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/08c99230c9e2e09afc500693aa716b… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/dcoutts/io-manager-tidy] Add interruptIOManager support for poll I/O manager
by Duncan Coutts (＠dcoutts) 15 Jul '26

15 Jul '26

Duncan Coutts pushed to branch wip/dcoutts/io-manager-tidy at Glasgow Haskell Compiler / GHC Commits: 3ed3922c by Duncan Coutts at 2026-07-08T12:26:05+01:00 Add interruptIOManager support for poll I/O manager Uses the FdWakup mechanism. A quirk we have to cope with is that we now need to poll one more fd -- the wakeup_fd_r -- but this fd has no corresponding entry in the aiop_table. This is awkward since we have set up our aiop_poll_table to be an auxilliary table with matching indicies. The solution this patch uses (and described in the comments) is to have two tables: struct pollfd *aiop_poll_table, *full_poll_table; and to have the aiop_poll_table alias the tail of the full_poll_table. The head entry in the full_poll_table is the extra fd. So we poll the full_poll_table, while the aiop_poll_table still has matching indicies with the aiop_table. Hurrah for C aliasing rules. - - - - - 5 changed files: - rts/IOManager.c - rts/IOManagerInternals.h - rts/posix/FdWakeup.h - rts/posix/Poll.c - rts/posix/Poll.h Changes: ===================================== rts/IOManager.c ===================================== @@ -745,7 +745,7 @@ bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr) #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: - awaitCompletedTimeoutsOrIOPoll(iomgr); + completed = awaitCompletedTimeoutsOrIOPoll(iomgr); break; #endif @@ -784,6 +784,12 @@ void interruptIOManager(CapIOManager *iomgr) break; #endif +#if defined(IOMGR_ENABLED_POLL) + case IO_MANAGER_POLL: + interruptIOManagerPoll(iomgr); + break; +#endif + default: break; } ===================================== rts/IOManagerInternals.h ===================================== @@ -46,10 +46,12 @@ struct _CapIOManager { StgTSO *sleeping_queue; #endif -#if defined(IOMGR_ENABLED_SELECT) - /* FDs for interrupting up the I/O manager when it is blocked waiting */ +#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_POLL) +#if defined(HAVE_PREEMPTION) + /* FDs for waking up the I/O manager when it is blocked waiting */ int interrupt_fd_r, interrupt_fd_w; #endif +#endif #if defined(IOMGR_ENABLED_POLL) /* AIOP and timeout collections shared by several I/O manager impls */ @@ -58,8 +60,11 @@ struct _CapIOManager { #endif #if defined(IOMGR_ENABLED_POLL) - /* Auxiliary table with size and indexes matching the aiop_table */ - struct pollfd *aiop_poll_table; + /* Auxiliary table with size and indexes matching the aiop_table. This is + * aliased to the tail of the full poll table, which has a head entry for + * the wakeup_fd_r above, so we can also poll that fd. + */ + struct pollfd *aiop_poll_table, *full_poll_table; #endif #if defined(IOMGR_ENABLED_WIN32_LEGACY) ===================================== rts/posix/FdWakeup.h ===================================== @@ -29,12 +29,14 @@ #include "BeginPrivate.h" +#if defined(HAVE_PREEMPTION) void newFdWakeup(int *fd_r, int *fd_w); void closeFdWakeup(int fd_r, int fd_w); /* This is safe to use from a signal handler */ void sendFdWakeup(int fd_w); void collectFdWakeup(int fd_r); +#endif #include "EndPrivate.h" ===================================== rts/posix/Poll.c ===================================== @@ -41,6 +41,7 @@ #include "IOManagerInternals.h" #include "Timeout.h" +#include "FdWakeup.h" /****************************************************************************** @@ -107,8 +108,9 @@ timeout (if any) as the poll() timeout parameter. The CapIOManager structure for this I/O manager contains: ClosureTable aiop_table; - struct pollfd *aiop_poll_table; + struct pollfd *aiop_poll_table, *full_poll_table; StgTimeoutQueue *timeout_queue; + int interrupt_fd_r, interrupt_fd_w; We also support the Linux-specific ppoll API which supports higher resolution time delays -- nanoseconds rather than milliseconds as in classic poll(). It @@ -117,6 +119,15 @@ also allows the signal mask to be adjusted, but we do not make use of this. int ppoll(struct pollfd *fds, nfds_t nfds, const struct timespec *tmo_p, const sigset_t *sigmask); +We have both aiop_poll_table and full_poll_table. This is to cope with needing +to wait on the special extra file descriptor interrupt_fd_r. This fd is used to +support waking the I/O manager when we are blocked in a poll call. This +requires waiting on an extra fd that has no corresponding entry in the +aiop_table. To manage this quirk, we alias the aiop_poll_table to be the tail +of the full_poll_table and have the first entry of the full_poll_table be the +interrupt_fd_r. This means the aiop_poll_table indicies match up exactly with +the aiop_table, but still allows the full_poll_table to have an extra entry. + ******************************************************************************/ /* Forward declarations */ @@ -129,16 +140,34 @@ static void reportPollError(int res, nfds_t nfds) STG_NORETURN; void initCapabilityIOManagerPoll(CapIOManager *iomgr) { initClosureTable(&iomgr->aiop_table, ClosureTableCompact); - iomgr->aiop_poll_table = NULL; iomgr->timeout_queue = emptyTimeoutQueue(); + +#if defined(HAVE_PREEMPTION) + newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w); +#endif + + iomgr->full_poll_table = stgMallocBytes(sizeof(struct pollfd) /* size 1 */, + "initCapabilityIOManagerPoll"); + iomgr->full_poll_table[0] = (struct pollfd) { +#if defined(HAVE_PREEMPTION) + .fd = iomgr->interrupt_fd_r, + .events = POLLIN, +#else + .fd = -1, // unused + .events = 0, // unused +#endif + .revents = 0 + }; + iomgr->aiop_poll_table = iomgr->full_poll_table+1; /* hence empty */ } void freeCapabilityIOManagerPoll(CapIOManager *iomgr) { - if (iomgr->aiop_poll_table) { - stgFree(iomgr->aiop_poll_table); - } + stgFree(iomgr->full_poll_table); +#if defined(HAVE_PREEMPTION) + closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w); +#endif } @@ -295,7 +324,7 @@ static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop) } -static void processIOCompletions(CapIOManager *iomgr, int ncompletions) +static bool processIOCompletions(CapIOManager *iomgr, int ncompletions) { /* The scheme we use with poll is that we have a dense poll table, and a * corresponding table that maps to the closure table index. The poll @@ -305,6 +334,19 @@ static void processIOCompletions(CapIOManager *iomgr, int ncompletions) */ debugTrace(DEBUG_iomanager, "processIOCompletions(ncompletions = %d)", ncompletions); + + bool interrupt = false; +#if defined(HAVE_PREEMPTION) + /* If the interrupt_fd_r is ready, collect it */ + if (iomgr->full_poll_table[0].revents) { + ASSERT(iomgr->full_poll_table[0].fd == iomgr->interrupt_fd_r); + collectFdWakeup(iomgr->interrupt_fd_r); + ncompletions--; + interrupt = true; + debugTrace(DEBUG_iomanager, "Received interrupt in poll I/O manager"); + } +#endif + struct pollfd *aiop_poll_table = iomgr->aiop_poll_table; int n = ncompletions; int i = 0; @@ -357,11 +399,14 @@ static void processIOCompletions(CapIOManager *iomgr, int ncompletions) i++; } } + return interrupt; } void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) { + ASSERT(iomgr->aiop_poll_table == iomgr->full_poll_table+1); + if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) { Time now = getProcessElapsedTime(); processTimeoutCompletions(iomgr, now); @@ -369,20 +414,28 @@ void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) if (!isEmptyClosureTable(&iomgr->aiop_table)) { - nfds_t nfds = sizeClosureTable(&iomgr->aiop_table); + nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 1; + +#if defined(HAVE_PREEMPTION) + /* the full_poll_table includes interrupt_fd_r */ + struct pollfd *poll_table = iomgr->full_poll_table; +#else + /* the aiop_poll_table does not include interrupt_fd_r */ + struct pollfd *poll_table = iomgr->aiop_poll_table; +#endif /* Poll for I/O readiness, without waiting. */ #if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 /* We could use poll here, since we use no timeout, but for consistency we use the same syscall as at the other call site. */ struct timespec tv = (struct timespec) { .tv_sec = 0, .tv_nsec = 0 }; - int res = ppoll(iomgr->aiop_poll_table, nfds, &tv, NULL); + int res = ppoll(poll_table, nfds, &tv, NULL); debugTrace(DEBUG_iomanager, "ppoll(nfds = %d, timeout.sec = 0, timeout.nsec = 0) = %d", nfds, res); #else - int res = poll(iomgr->aiop_poll_table, nfds, 0); + int res = poll(poll_table, nfds, 0); debugTrace(DEBUG_iomanager, "poll(nfds = %d, timeout_ms = 0) = %d", @@ -408,8 +461,12 @@ void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) } -void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) +bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) { + bool interrupt = false; /* got woken up via interruptIOManager */ + + ASSERT(iomgr->aiop_poll_table == iomgr->full_poll_table+1); + /* Loop until we've woken up some threads. This loop is needed because the * poll() timing isn't accurate, we sometimes sleep for a while but not * long enough to wake up a thread in a threadDelay. Or we may need to @@ -431,6 +488,14 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) */ bool wait = emptyRunQueue(iomgr->cap); +#if defined(HAVE_PREEMPTION) + /* the full_poll_table includes interrupt_fd_r */ + struct pollfd *poll_table = iomgr->full_poll_table; +#else + /* the aiop_poll_table does not include interrupt_fd_r */ + struct pollfd *poll_table = iomgr->aiop_poll_table; +#endif + /* Decide if we are going to wait if no I/O is ready, either: * poll only, wait indefinitely, or wait until a timeout. */ @@ -442,9 +507,9 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) #endif /* Check for I/O readiness, possibly waiting. */ - nfds_t nfds = sizeClosureTable(&iomgr->aiop_table); + nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 1; #if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 - int res = ppoll(iomgr->aiop_poll_table, nfds, timeout_ns, NULL); + int res = ppoll(poll_table, nfds, timeout_ns, NULL); debugTrace(DEBUG_iomanager, "ppoll(nfds = %d, timeout.sec = %d, timeout.nsec = %d) = %d", @@ -452,7 +517,7 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) timeout_ns == NULL ? 0 : timeout_ns->tv_nsec, res); #else - int res = poll(iomgr->aiop_poll_table, nfds, timeout_ms); + int res = poll(poll_table, nfds, timeout_ms); debugTrace(DEBUG_iomanager, "poll(nfds = %d, timeout_ms = %d) = %d", @@ -474,7 +539,7 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) } else if (res > 0) { int ncompletions = res; ASSERT(ncompletions <= (int)nfds); - processIOCompletions(iomgr, ncompletions); + interrupt = processIOCompletions(iomgr, ncompletions); // FIXME: do we also need to check for timeout completions now? // we have a non-empty queue, but if !wait then we have also moved // on and so we sould check for timeouts. @@ -502,7 +567,9 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) } } while (emptyRunQueue(iomgr->cap) + && !interrupt && (getSchedState() == SCHED_RUNNING)); + return !interrupt; } static void reportPollError(int res, nfds_t nfds) @@ -521,6 +588,14 @@ static void reportPollError(int res, nfds_t nfds) } +void interruptIOManagerPoll(CapIOManager *iomgr) +{ +#if defined(HAVE_PREEMPTION) + sendFdWakeup(iomgr->interrupt_fd_w); +#endif +} + + /* Helper function to double the size of the aiop_table and aiop_poll_table. */ static bool enlargeTables(CapIOManager *iomgr) @@ -531,13 +606,17 @@ static bool enlargeTables(CapIOManager *iomgr) bool ok = enlargeClosureTable(iomgr->cap, &iomgr->aiop_table, newcapacity); if (RTS_UNLIKELY(!ok)) return false; - /* Update the auxiliary aiop_poll_table to match */ - struct pollfd *aiop_poll_table; - aiop_poll_table = stgReallocBytes(iomgr->aiop_poll_table, - sizeof(struct pollfd) * newcapacity, - "Poll.c: enlargeTables"); - iomgr->aiop_poll_table = aiop_poll_table; + /* Update the auxiliary aiop_poll_table to match. The full_poll_table is + * one bigger than the aiop_poll_table, since it has an extra entry at the + * front for interrupt_fd_r, with no corresponding aiop. */ + iomgr->full_poll_table = + stgReallocBytes(iomgr->full_poll_table, + sizeof(struct pollfd) * (newcapacity+1), + "Poll.c: enlargeTables"); + iomgr->aiop_poll_table = iomgr->full_poll_table+1; + /* Initialise the new part of the aiop_poll_table */ + struct pollfd *aiop_poll_table = iomgr->aiop_poll_table; for (int i = oldcapacity; i < newcapacity; i++) { aiop_poll_table[i] = (struct pollfd) { .fd = -1, ===================================== rts/posix/Poll.h ===================================== @@ -32,7 +32,8 @@ void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop); /* Scheduler operations */ bool anyPendingTimeoutsOrIOPoll(CapIOManager *iomgr); void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr); -void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr); +bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr); +void interruptIOManagerPoll(CapIOManager *iomgr); #endif /* IOMGR_ENABLED_POLL */ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ed3922c26d258eb76b33d1ab4256ca… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ed3922c26d258eb76b33d1ab4256ca… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/27461] 2 commits: downsweep: make control flow simpler and cache correct
by Rodrigo Mesquita (＠alt-romes) 15 Jul '26

15 Jul '26

Rodrigo Mesquita pushed to branch wip/romes/27461 at Glasgow Haskell Compiler / GHC Commits: c1643fe3 by Rodrigo Mesquita at 2026-07-15T10:09:46+01:00 downsweep: make control flow simpler and cache correct This refactor extracts the control flow of downsweep into a single function `dfsBuild`, which takes care of iteratively expanding and traversing all nodes of the in-construction module graph necessary to build a full `ModuleGraph`. There are three levels of caching going on, all of which are necessary to make sure we don't do repeated work (notably, NEVER summarise the same module twice). 1. `dfsBuild` accumulates the final module graph and never revisits the same node of the module graph. Cache is keyed by the final `ModuleGraph`s `NodeKey`s. 2. For Module A in home-unit u1, each import in the list of imports needs to be *found* (call to `findImportedModuleWithIsBoot`): at this point, we only have the `ModuleName` of the import, not the `Module`. This *finding* is somewhat expensive, so we cache it as well (`ImportsCache`). The cache key is the home-unit to which the module belongs~[1], the import package qualifier, and the ModuleName. [1] Different home-units will have different package flags, which means potentially different `Module` resolution for the same `ModuleName`. 3. The most expensive operation we want to avoid is summarising a `Module` into a `ModSummary`, which notably involves parsing the module header from scratch. The third cache, in essence, maps a `Module` to its `ModSummary` (named `ModSummaryCache`). This cache upholds the invariant: we NEVER summarise the same module twice. In practice, the cache key is the Module's UnitId and the Source path; the reason is we need to distinguish between `.hs` and `.hs-boot` files, as their summaries will differ. Note that (2) can't guarantee this alone: Two ModuleName imports in separate units can (and likely do) map to the same `Module`. Note that the previous implementation failed to achieve the no-duplicate-work summarisation invariant, and we ended up doing a quadratic amount of processing in scenarios like test `MultiComponentModules100`. See also Note [Downsweep Control Flow and Caching] Fixes #27461 Perf changes: MultiComponentModules(normal) ghc/alloc 2,097,389,264 1,992,186,736 -5.0% GOOD MultiComponentModules100(normal) ghc/alloc 24,310,173,770 21,293,867,360 -12.4% GOOD MultiComponentModulesRecomp(normal) ghc/alloc 602,761,394 498,543,984 -17.3% GOOD MultiComponentModulesRecomp100(normal) ghc/alloc 11,885,968,240 8,895,404,864 -25.2% GOOD ------------------------- Metric Decrease: MultiComponentModules MultiComponentModules100 MultiComponentModulesRecomp MultiComponentModulesRecomp100 ------------------------- - - - - - 39c83aef by Rodrigo Mesquita at 2026-07-15T10:12:27+01:00 implicitRequirementsShallow can never reach HoleUnit findImportedModule will never return `HoleUnit` for a `ModuleName` (a `HoleUnit` can only be found as a signature instantiation, never as a directly *imported* thing) Therefore, we can drop `[ModuleName]` returned by `implicitRequirementsShallow`, which makes many things dead code. Namely, the call to `implicitRequirementsShallow` from GHC.Driver.Downsweep which was a performance bottleneck (for doing lots of duplicate work in findImportedModule) is now entirely gone. Fixes #27053 In an MR with this patch and the downsweep refactor (previous commit), CI says: MultiComponentModules(normal) ghc/alloc 2,097,396,728 1,943,662,304 -7.3% GOOD MultiComponentModules100(normal) ghc/alloc 24,310,182,136 17,227,574,440 -29.1% GOOD MultiComponentModulesRecomp(normal) ghc/alloc 602,769,518 449,973,656 -25.3% GOOD MultiComponentModulesRecomp100(normal) ghc/alloc 11,885,976,408 4,828,894,160 -59.4% GOOD ------------------------- Metric Decrease: MultiComponentModules MultiComponentModules100 MultiComponentModulesRecomp MultiComponentModulesRecomp100 ------------------------- - - - - - 8 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Tc/Utils/Backpack.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/splice-imports/SI35.hs - utils/check-ppr/Main.hs Changes: ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -888,7 +888,7 @@ hsModuleToModSummary home_keys pn hsc_src modname extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname let normal_imports = map convImport (generated_imports ++ ord_idecls) - (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports + inst_deps <- liftIO $ implicitRequirementsShallow hsc_env normal_imports -- So that Finder can find it, even though it doesn't exist... this_mod <- liftIO $ do @@ -909,8 +909,7 @@ hsModuleToModSummary home_keys pn hsc_src modname -- We have to do something special here: -- due to merging, requirements may end up with -- extra imports - ++ ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) - ++ ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs), + ++ ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports), -- This is our hack to get the parse tree to the right spot ms_parsed_mod = Just (HsParsedModule { hpm_module = hsmod, ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -5,6 +5,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FunctionalDependencies #-} module GHC.Driver.Downsweep ( downsweep , downsweepThunk @@ -91,7 +93,7 @@ import GHC.Unit.Module.Deps import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Module.Stage -import Data.Either ( rights, partitionEithers, lefts ) +import Data.Either ( partitionEithers, lefts ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -111,6 +113,8 @@ import Control.Monad.Trans.Reader import qualified Data.Map.Strict as M import Control.Monad.Trans.Class import System.IO.Unsafe (unsafeInterleaveIO) +import Data.IORef +import qualified Data.List.NonEmpty as NE {- Note [Downsweep and the ModuleGraph] @@ -140,16 +144,9 @@ When is this graph constructed? The result is having a uniform graph available for the whole compilation pipeline. +See also Note [Downsweep Control Flow and Caching] -} --- This caches the answer to the question, if we are in this unit, what does --- an import of this module mean. -type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo] - -moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode -moduleGraphNodeMap graph - = M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph] - ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) for --make mode @@ -195,8 +192,11 @@ downsweep :: HscEnv -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allow_dup_roots = do - n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) - (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary + n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) + summ_cache <- newIORef (mkModSummaryCache (zip old_summaries (repeat SummOld))) + imps_cache <- newIORef Map.empty + (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg + (getRootSummary excl_mods summ_cache imps_cache) let closure_errs = checkHomeUnitsClosed unit_env unit_env = hsc_unit_env hsc_env @@ -204,9 +204,13 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo case all_errs of [] -> do - (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map maybe_base_graph excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] + (downsweep_errs, downsweep_nodes) <- + downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph + excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] - let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) + let (other_errs, unit_nodes) = partitionEithers $ + HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] + (hsc_HUG hsc_env) let all_nodes = downsweep_nodes ++ unit_nodes let all_errs = downsweep_errs ++ other_errs @@ -222,17 +226,6 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo return (all_errs, th_configured_nodes) _ -> return (all_errs, emptyMG) where - summary = getRootSummary excl_mods old_summary_map - - -- A cache from file paths to the already summarised modules. The same file - -- can be used in multiple units so the map is also keyed by which unit the - -- file was used in. - -- Reuse these if we can because the most expensive part of downsweep is - -- reading the headers. - old_summary_map :: M.Map (UnitId, OsPath) ModSummary - old_summary_map = - M.fromList [((ms_unitid ms, msHsFileOsPath ms), ms) | ms <- old_summaries] - -- Dependencies arising on a unit (backpack and module linking deps) unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] unitModuleNodes summaries uid hue = @@ -245,7 +238,9 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." - ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] + summs <- newIORef (mkModSummaryCache [(mod_summary,SummOld)]) + imps <- newIORef mempty + ~(errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] let dflags = hsc_dflags hsc_env liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) (initPrintConfig dflags) @@ -269,83 +264,22 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...") let imps = ic_imports (hsc_IC hsc_env) - let interactive_mn = icInteractiveModule ic - -- No sensible value for ModLocation.. if you hit this panic then you probably - -- need to add proper support for modules without any source files to the driver. - let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps) - let key = moduleToMnk interactive_mn NotBoot - let node_type = ModuleNodeFixed key ml + interactive_mn = icInteractiveModule ic + key = dsNodeInfoKey (DSInteractive interactive_mn imps) -- The existing nodes in the module graph. This will be populated when GHCi runs -- :load. Any home package modules need to already be in here. let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ] - (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes - let interactive_node = ModuleNode module_edges node_type - - let all_nodes = M.elems graph + summ_cache <- newIORef mempty + imps_cache <- newIORef mempty + let env = DownsweepEnv hsc_env DownsweepUseFixed{-or UseCompiled?-} summ_cache imps_cache [] + graph <- runDownsweepM env do + loopFromInteractive cached_nodes interactive_mn imps + let interactive_node = expectJust $ M.lookup key graph + all_nodes = M.elems graph return $ mkModuleGraph (interactive_node : all_nodes) - where - -- - mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) - -- A simple edge to a module from the same home unit - mkEdge (IIModule n) = - let - mod_node_key = ModNodeKeyWithUid - { mnkModuleName = GWIB (moduleName n) NotBoot - , mnkUnitId = - -- 'toUnitId' is safe here, as we can't import modules that - -- don't have a 'UnitId'. - toUnitId (moduleUnit n) - } - mod_node_edge = - ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key) - in Left mod_node_edge - -- 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 Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) - -loopFromInteractive :: HscEnv - -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] - -> M.Map NodeKey ModuleGraphNode - -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode) -loopFromInteractive _ [] cached_nodes = return ([], cached_nodes) -loopFromInteractive hsc_env (edge:edges) cached_nodes = - case edge of - Left edge -> do - (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes - return (edge : edges, cached_nodes') - Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do - let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) - let k _ loc mod = - let key = moduleToMnk mod is_boot - in return $ FoundHome (ModuleNodeFixed key loc) - found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg [] - case found of - -- Case 1: Home modules have to already be in the cache. - FoundHome (ModuleNodeFixed mod _) -> do - let edge = ModuleNodeEdge lvl (NodeKey_Module mod) - -- Note: Does not perform any further downsweep as the module must already be in the cache. - (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes - return (edge : edges, cached_nodes') - -- Case 2: External units may not be in the cache, if we haven't already initialised the - -- module graph. We can construct the module graph for those here by calling loopUnit. - External uid -> do - let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env - cached_nodes' = loopUnit hsc_env' cached_nodes [uid] - edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) - (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes' - return (edge : edges, cached_nodes') - -- And if it's not found.. just carry on and hope. - _ -> loopFromInteractive hsc_env edges cached_nodes - - -- | 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 @@ -373,7 +307,9 @@ downsweepInstalledModules hsc_env mods = do _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i nodes <- mapM process installed_mods - (errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed nodes external_uids + summs <- newIORef mempty + imps <- newIORef mempty + (errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed nodes external_uids -- Similarly here, we should really not get any errors, but print them out if we do. let dflags = hsc_dflags hsc_env @@ -397,7 +333,8 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed -- This function will start at the given roots, and traverse downwards to find -- all the dependencies, all the way to the leaf units. downsweepFromRootNodes :: HscEnv - -> M.Map (UnitId, OsPath) ModSummary + -> ModSummaryCache + -> ImportsCache -> Maybe ModuleGraph -> [ModuleName] -> Bool @@ -405,44 +342,48 @@ downsweepFromRootNodes :: HscEnv -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo -> [UnitId] -- ^ The starting units -> IO ([DriverMessages], [ModuleGraphNode]) -downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids - = do - let root_map = mkRootMap root_nodes - checkDuplicates root_map - let env = DownsweepEnv hsc_env mode old_summaries excl_mods - (deps', map0) <- runDownsweepM env $ do - let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph - (module_deps, map0) <- loopModuleNodeInfos root_nodes (base_nodes, 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 downsweep_errs = lefts $ concat $ M.elems map0 - downsweep_nodes = M.elems deps' - - return (downsweep_errs, downsweep_nodes) - where - getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] - getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) - - -- 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 - -- ignored, leading to confusing behaviour). - checkDuplicates - :: DownsweepCache - -> IO () - checkDuplicates root_map - | not allow_dup_roots - , dup_root:_ <- dup_roots = liftIO $ multiRootsErr sec dup_root - | otherwise = pure () - where - sec = initSourceErrorContext (hsc_dflags hsc_env) - dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2 - dup_roots = filterOut isSingleton $ map rights (M.elems root_map) - +downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids = do + when (not allow_dup_roots) $ + case root_duplicates of + [] -> return () + (dup_root:_) -> multiRootsErr sec dup_root + modifyImpsCache imps_cache (`M.union` mkRootMap root_nodes) -- add root nodes to imports cache + let env = DownsweepEnv hsc_env mode summ_cache imps_cache excl_mods + deps' <- runDownsweepM env $ do + let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph + module_deps <- loopModuleNodeInfos base_nodes root_nodes + all_deps <- loopUnits module_deps (hscActiveUnitId hsc_env) root_uids + deps' <- loopInstantiations all_deps (getHomeUnitInstantiations hsc_env) + return deps' + f_cache <- readIORef summ_cache + let downsweep_errs = lefts (M.elems f_cache) + downsweep_nodes = M.elems deps' + + return (downsweep_errs, downsweep_nodes) + where + getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] + getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey + (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) + + -- 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 + -- ignored, leading to confusing behaviour). + root_duplicates :: [NE.NonEmpty ModuleNodeInfo] + root_duplicates = mapMaybe takes2 (M.elems root_map) + where + takes2 (a:as@(_:_)) = Just (a NE.:| as) -- Each at least of length 2 + takes2 _ = Nothing + + root_map = Map.fromListWith (flip (++)) + [ ((moduleNodeInfoUnitId s, moduleNodeInfoMnwib s), [s]) + | s <- root_nodes ] + + moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode + moduleGraphNodeMap graph + = M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph] + + sec = initSourceErrorContext (hsc_dflags hsc_env) calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] calcDeps ms = @@ -457,104 +398,292 @@ type DownsweepM a = ReaderT DownsweepEnv IO a data DownsweepEnv = DownsweepEnv { downsweep_hsc_env :: HscEnv , _downsweep_mode :: DownsweepMode - , _downsweep_old_summaries :: M.Map (UnitId, OsPath) ModSummary + , _downsweep_summaries_cache :: ModSummaryCache + , downsweep_imports_cache :: ImportsCache , _downsweep_excl_mods :: [ModuleName] } +type ModSummaryCache = IORef ModSummaryCacheMap +type ImportsCache = IORef ImportsCacheMap + +-- | A cache from file paths to the already summarised modules. The same file +-- can be used in multiple units so the map is actually also keyed by which +-- unit the file was used in. +-- +-- We want to reuse ModSummaries as far as possible because the most expensive +-- part of downsweep is reading and parsing the headers. +-- +-- See Note [Downsweep Control Flow and Caching] +type ModSummaryCacheMap + -- The cache can't be keyed by 'Module' because that isn't sufficient to + -- distinguish .hs from .hs-boot files. Use path+unit instead. + = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) ) + +data SummProvenance + -- | Constructed during this downsweep: trivially up to date + = SummFresh + -- | Carried over from a previous run: may be stale, must be hash-checked + -- (and considered by -fforce-recomp) + | SummOld + +mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap +mkModSummaryCache summs = foldl' (flip (uncurry addModSummaryCache)) M.empty summs + +addModSummaryCache :: ModSummary -> SummProvenance -> ModSummaryCacheMap -> ModSummaryCacheMap +addModSummaryCache ms pr fe = upd_fe fe + where + upd_fe fe + | Just src_fn_os <- ml_hs_file_ospath (ms_location ms) + = M.insert (ms_unitid ms, src_fn_os) (Right (ms, pr)) fe + | otherwise = fe + +modifySummCache :: ModSummaryCache -> (ModSummaryCacheMap -> ModSummaryCacheMap) -> IO () +modifyImpsCache :: ImportsCache -> (ImportsCacheMap -> ImportsCacheMap) -> IO () +modifySummCache r f = atomicModifyIORef' r (\c -> (f c, ())) +modifyImpsCache r f = atomicModifyIORef' r (\c -> (f c, ())) + +-- | A cache from a module import (in given home unit context, with a package +-- qualifier, and the imported module name (with or without SOURCE)) to the +-- result of summarising that import (see 'summariseModuleDispatch'). +-- +-- See Note [Downsweep Control Flow and Caching] +type ImportsCacheMap + = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) SummariseResult + +-- | Populate the 'ImportsCacheMap' with the root modules. +mkRootMap :: [ModuleNodeInfo] -> ImportsCacheMap +mkRootMap summaries = Map.fromList + [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), FoundHome s) | s <- summaries ] + runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a runDownsweepM env act = runReaderT act env +loopDownsweepNodes :: M.Map NodeKey ModuleGraphNode -> [DownsweepNode] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopModuleNodeInfos :: M.Map NodeKey ModuleGraphNode -> [ModuleNodeInfo] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopUnits :: M.Map NodeKey ModuleGraphNode -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopInstantiations :: M.Map NodeKey ModuleGraphNode -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFromInteractive :: M.Map NodeKey ModuleGraphNode -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopDownsweepNodes base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand +loopModuleNodeInfos base_map = loopDownsweepNodes base_map . map DSMod +loopUnits base_map homud = loopDownsweepNodes base_map . map (DSUnit homud) +loopInstantiations base_map = loopDownsweepNodes base_map . map (uncurry DSInst) +loopFromInteractive base_map m = loopDownsweepNodes base_map . (:[]) . DSInteractive m + +-------------------------------------------------------------------------------- + +-- | A 'DownsweepNode' is the basic block of the downsweep algorithm which +-- encompasses the types of nodes we can iteratively expand to construct the +-- full module graph. See 'loopDownsweepNodes'. +-- +-- See Note [Downsweep Control Flow and Caching] +data DownsweepNode + -- | A module node to expand + = DSMod ModuleNodeInfo + -- | A unit node to expand + | DSUnit + { home_context_uid :: UnitId + -- ^ The home unit which introduced the dependency on this 'node_uid'. This + -- 'node_uid' can only be expanded in the context ('HscEnv') where + -- 'home_context_uid' is the active home unit, to make sure the package flags + -- are the ones attributed to the home package that introduced this node. + , node_uid :: UnitId + -- ^ The unit node to expand + } + -- | FIXME: document the meaning of 'DSInst' + | DSInst + { home_context_uid :: UnitId + , instantiated_ud :: InstantiatedUnit + } + -- | A group of interactive imports from this interactive Module + | DSInteractive Module [InteractiveImport] + +instance Outputable DownsweepNode where + ppr = \case + DSMod (ModuleNodeCompile ms) -> text "DSModC" <+> ppr (ms_mod_name ms) + DSMod (ModuleNodeFixed key _) -> text "DSModF" <+> ppr key + DSUnit{node_uid} -> text "DSUnit" <+> ppr node_uid + DSInst{instantiated_ud} -> text "DSInst" <+> ppr instantiated_ud + DSInteractive mod ii -> text "DSInteractive" <+> ppr mod <+> ppr ii + +-- | They key by which to cache previously visited 'DownsweepNode's +dsNodeInfoKey :: DownsweepNode -> NodeKey +dsNodeInfoKey = \case + DSMod (ModuleNodeCompile ms) -> NodeKey_Module (msKey ms) + DSMod (ModuleNodeFixed mod _) -> NodeKey_Module mod + DSUnit{node_uid} -> NodeKey_ExternalUnit node_uid + DSInst{instantiated_ud} -> NodeKey_Unit instantiated_ud + DSInteractive mod _imps -> NodeKey_Module $ moduleToMnk mod NotBoot + +dsNodeExpand :: DownsweepNode -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +dsNodeExpand = \case + DSMod (ModuleNodeCompile ms) -> expandModuleSummary ms + DSMod (ModuleNodeFixed key loc) -> expandFixedModuleNode key loc + DSUnit{ node_uid, home_context_uid } -> expandUnitNode node_uid home_context_uid + DSInst{ instantiated_ud + , home_context_uid } -> expandInstantiatedUnit instantiated_ud home_context_uid + DSInteractive imod iis -> expandInteractiveImports imod iis + +expandModuleSummary :: ModSummary -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that. + hsc_env <- asks downsweep_hsc_env + let home_uid = ms_unitid ms + home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + (final_deps, todo) <- fmap unzip $ forM (calcDeps ms) $ \(imp,mb_pkg,gwib) -> do + let GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib + wanted_mod = L loc mod + mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing + case mb_s of + NotThere -> return + ( Nothing, [] ) + External uid -> return + ( Just $ mkModuleEdge imp (NodeKey_ExternalUnit uid) + -- Specify home unit, as each unit might have a different visible package database. + , [DSUnit{node_uid = uid, home_context_uid = home_uid}] ) + FoundInstantiation iud -> return + ( Just (mkModuleEdge imp (NodeKey_Unit iud)), [] ) + FoundHomeWithError (_uid, _e) -> return + ( Nothing, [] ) + -- the error @e@ is already stored in the summarisation cache, + -- (the IORef in DownsweepM) and will get reported at the end. + FoundHome s -> return + -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. + ( Just $ mkModuleEdge imp (NodeKey_Module (mnKey s)) + , [DSMod s] ) + + -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. + boot_todo <- + if | HsBootFile <- ms_hsc_src ms + -> do + r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing + case r of + FoundHome s -> pure [DSMod s] + _ -> pure [] + | otherwise -> pure [] + + return $ Just + ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms) + , boot_todo ++ concat todo + ) + +-- | Expand a 'ModuleNodeFixed' node +-- NB: If you ever reach a Fixed node, everything under that also must be fixed. +expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandFixedModuleNode key loc = do + hsc_env <- asks downsweep_hsc_env + -- 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_hooks hsc_env) (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) + deps' <- catMaybes <$> mapM (mk_dep hsc_env) (bimap snd snd <$> node_deps) + pure $ Just (node, deps') + + -- Ignore any failure, we might try to read a .hi-boot file for + -- example, even if there is not one. + M.Failed {} -> + pure Nothing + where + mk_dep hsc_env (Left key) = do + -- Like expandImports, but we already know exactly which module we are looking for. + read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) + case read_result of + InstalledFound loc -> do + pure $ Just $ DSMod (ModuleNodeFixed key loc) + _otherwise -> + -- If the finder fails, just keep going, there will be another + -- error later. + pure Nothing + mk_dep _ (Right uid_dep) = do + -- Set active unit so that looking loopUnit finds the correct + -- -package flags in the unit state. + let home_uid = mnkUnitId key + pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid}) + +-- | Expand a unit id under the context of a certain home unit +expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -} + -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandUnitNode node_uid home_context_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 lcl_hsc_env = hscSetActiveUnitId home_context_uid hsc_env + case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) node_uid of + Just us -> pure $ Just ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us) + Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr node_uid) + +expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandInstantiatedUnit iud home_uid = pure $ Just + ( InstantiationNode home_uid iud + , [DSUnit{node_uid=instUnitInstanceOf iud, home_context_uid=home_uid}] ) + +expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode])) +expandInteractiveImports imod imps = do + hsc_env <- asks downsweep_hsc_env + imps_cache <- asks downsweep_imports_cache + + let + -- A simple edge to a module from the same home unit + mkEdge (IIModule n) = return $ + let + mod_node_key = ModNodeKeyWithUid + { mnkModuleName = GWIB (moduleName n) NotBoot + , mnkUnitId = + -- 'toUnitId' is safe here, as we can't import modules that + -- don't have a 'UnitId'. + toUnitId (moduleUnit n) + } + in (Just $ ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key), []) -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 (ms_unitid ms) (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 (ms_unitid ms) (maybeToList hs_file_for_boot) done' summarised' - loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') + -- 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 do + let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) + let k _ loc mod = + let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + + found <- liftIO $ summariseModuleDispatch k hsc_env imps_cache + home_unit is_boot (noLoc wanted_mod) mb_pkg [] + case found of + -- Case 1: Home modules have to already be in the cache. + FoundHome (ModuleNodeFixed mod _) -> do + let edge = ModuleNodeEdge lvl (NodeKey_Module mod) + -- Note: Does not perform any further downsweep as the module must already be in the cache. + return (Just edge, []) + -- Case 2: External units may not be in the cache, if we haven't already initialised the + -- module graph. We can construct the module graph for those here by calling loopUnit. + External uid -> do + let edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) + return (Just edge, [DSUnit{node_uid=uid, home_context_uid=homeUnitId home_unit}]) + -- And if it's not found.. just carry on and hope. + _ -> return (Nothing, []) + + (module_edges, todo) <- unzip <$> mapM mkEdge imps + pure $ Just + ( ModuleNode (catMaybes module_edges) node_type, concat todo ) where - k = NodeKey_Module (msKey ms) + -- No sensible value for ModLocation.. if you hit this panic then you probably + -- need to add proper support for modules without any source files to the driver. + ml = pprPanic "modLocation" (ppr imod <+> ppr imps) + key = moduleToMnk imod NotBoot + node_type = ModuleNodeFixed key ml - hs_file_for_boot - | HsBootFile <- ms_hsc_src ms - = Just (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_hooks hsc_env) (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) @@ -569,27 +698,6 @@ ifaceDeps deps = | (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 @@ -597,90 +705,22 @@ downsweepSummarise :: HomeUnit -> 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 - -- ^ UnitId of home unit of summary whose imports are being processed - -> [(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') <- loopImportsNext done summarised - return (nk: rest, summarised', done') - [Left _err] -> - loopImportsNext done summarised - _errs -> do - loopImportsNext 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 -> loopImportsNext 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') <- loopImportsNext done' summarised - return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised') - FoundInstantiation iud -> do - (other_deps, done', summarised') <- loopImportsNext done summarised - return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised') - FoundHomeWithError (_uid, e) -> loopImportsNext 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) <- loopImportsNext 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 - loopImportsNext = loopImports home_uid ss - 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 :: SourceErrorContext -> [ModuleNodeInfo] -> IO () -multiRootsErr _ [] = panic "multiRootsErr" -multiRootsErr sec summs@(summ1:_) + DownsweepEnv hsc_env mode summaries_cache_ref imports_cache_ref excl_mods <- ask + liftIO $ case mode of + DownsweepUseCompile -> + summariseModule hsc_env home_unit summaries_cache_ref imports_cache_ref + is_boot wanted_mod mb_pkg maybe_buf excl_mods + DownsweepUseFixed -> + summariseModuleInterface hsc_env home_unit imports_cache_ref is_boot + wanted_mod mb_pkg excl_mods + +multiRootsErr :: SourceErrorContext -> NE.NonEmpty ModuleNodeInfo -> IO () +multiRootsErr sec (summ1 NE.:| summs) = throwOneError sec $ fmap GhcDriverMessage $ mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files where mod = moduleNodeInfoModule summ1 - files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs + files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) (summ1:summs) moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod) @@ -734,24 +774,25 @@ linkNodes summaries uid hue = getRootSummary :: [ModuleName] -> - M.Map (UnitId, OsPath) ModSummary -> + ModSummaryCache -> + ImportsCache -> HscEnv -> Target -> IO (Either DriverMessages ModSummary) -getRootSummary excl_mods old_summary_map hsc_env target +getRootSummary excl_mods summ_cache imports_cache hsc_env target | TargetFile file mb_phase <- targetId = do let offset_file = augmentByWorkingDirectory dflags file exists <- liftIO $ doesFileExist offset_file if exists || isJust maybe_buf - then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase + then summariseFile hsc_env home_unit summ_cache offset_file mb_phase maybe_buf else return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) | TargetModule modl <- targetId = do - maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot + maybe_summary <- summariseModule hsc_env home_unit summ_cache imports_cache NotBoot (L rootLoc modl) (ThisPkg (homeUnitId home_unit)) maybe_buf excl_mods pure case maybe_summary of @@ -1179,13 +1220,6 @@ Potential TODOS: generating temporary ones. -} --- | Populate the Downsweep cache with the root modules. -mkRootMap - :: [ModuleNodeInfo] - -> DownsweepCache -mkRootMap summaries = Map.fromListWith (flip (++)) - [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ] - ----------------------------------------------------------------------------- -- Summarising modules @@ -1202,33 +1236,39 @@ mkRootMap summaries = Map.fromListWith (flip (++)) summariseFile :: HscEnv -> HomeUnit - -> M.Map (UnitId, OsPath) ModSummary -- old summaries + -> ModSummaryCache -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) -> IO (Either DriverMessages ModSummary) -summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries - = do - let location = ms_location $ old_summary - - src_hash <- get_src_hash - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getFileHash may fail, but that's the right - -- behaviour. - - -- return the cached summary if the source didn't change - checkSummaryHash - hsc_env (new_summary src_fn) - old_summary location src_hash - - | otherwise - = do src_hash <- get_src_hash - new_summary src_fn src_hash +summariseFile hsc_env' home_unit summ_cache_ref src_fn mb_phase maybe_buf + = do file_summ_cache <- readIORef summ_cache_ref + case M.lookup (homeUnitId home_unit, src_fn_os) file_summ_cache of + Just (Right (chd_summary, SummFresh)) -> + -- Fresh: use it straight away + pure (Right chd_summary) + Just (Right (old_summary, SummOld)) -> do + -- we can use a cached summary if one is available and the + -- source file hasn't changed, + let location = ms_location $ old_summary + + src_hash <- get_src_hash + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getFileHash may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + res <- checkSummaryHash + hsc_env (new_summary src_fn) + old_summary location src_hash + case res of + Right ms -> modifySummCache summ_cache_ref (addModSummaryCache ms SummFresh) + Left _ -> pure () + return res + _ -> do src_hash <- get_src_hash + new_summary src_fn src_hash where -- change the main active unit so all operations happen relative to the given unit hsc_env = hscSetActiveHomeUnit home_unit hsc_env' @@ -1239,7 +1279,8 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf Just (buf,_) -> return $ fingerprintStringBuffer buf Nothing -> liftIO $ getFileHash src_fn - new_summary src_fn src_hash = runExceptT $ do + new_summary src_fn src_hash = do + res <- runExceptT $ do preimps@PreprocessedImports {..} <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf @@ -1270,6 +1311,10 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf , nms_mod = mod , nms_preimps = preimps } + modifySummCache summ_cache_ref $ case res of + Left e -> M.insert (homeUnitId home_unit, src_fn_os) (Left e) + Right ms -> addModSummaryCache ms SummFresh + return res checkSummaryHash :: HscEnv @@ -1322,15 +1367,16 @@ data SummariseResult = -- --make mode. summariseModule :: HscEnv -> HomeUnit - -> M.Map (UnitId, OsPath) ModSummary + -> ModSummaryCache + -> ImportsCache -> IsBootInterface -> Located ModuleName -> PkgQual -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -> IO SummariseResult -summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = - summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods +summariseModule hsc_env home_unit old_summaries imps_cache is_boot wanted_mod mb_pkg maybe_buf excl_mods = + summariseModuleDispatch k hsc_env imps_cache home_unit is_boot wanted_mod mb_pkg excl_mods where k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf @@ -1339,13 +1385,14 @@ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_ -- This version always returns a ModuleNodeFixed node. summariseModuleInterface :: HscEnv -> HomeUnit + -> ImportsCache -> IsBootInterface -> Located ModuleName -> PkgQual -> [ModuleName] -> IO SummariseResult -summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods = - summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods +summariseModuleInterface hsc_env home_unit imps_cache is_boot wanted_mod mb_pkg excl_mods = + summariseModuleDispatch k hsc_env imps_cache home_unit is_boot wanted_mod mb_pkg excl_mods where k _hsc_env loc mod = do -- The finder will return a path to the .hi-boot even if it doesn't actually @@ -1362,6 +1409,7 @@ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods = summariseModuleDispatch :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module. -> HscEnv + -> ImportsCache -> HomeUnit -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised @@ -1370,7 +1418,7 @@ summariseModuleDispatch -> IO SummariseResult -summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods +summariseModuleDispatch k hsc_env' imps_cache_ref home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods | wanted_mod `elem` excl_mods = return NotThere | otherwise = find_it @@ -1380,112 +1428,133 @@ summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg exc hsc_env = hscSetActiveHomeUnit home_unit hsc_env' find_it :: IO SummariseResult - find_it = do - found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg - case found of - Found location mod - | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env -> - -- Home package - k hsc_env location mod - | VirtUnit iud <- moduleUnit mod - , not (isHomeModule home_unit mod) - -> return $ FoundInstantiation iud - | otherwise -> return $ External (moduleUnitId mod) - _ -> return NotThere - -- Not found - -- (If it is TRULY not found at all, we'll - -- error when we actually try to compile) - + imps_cache <- readIORef imps_cache_ref + case M.lookup cache_key imps_cache of + Just result -> return result + Nothing -> do + found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg + r <- case found of + Found location mod + | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env -> + -- Home package + k hsc_env location mod + | VirtUnit iud <- moduleUnit mod + , not (isHomeModule home_unit mod) + -> return $ FoundInstantiation iud + | otherwise -> return $ External (moduleUnitId mod) + _ -> return NotThere + -- Not found + -- (If it is TRULY not found at all, we'll + -- error when we actually try to compile) + modifyImpsCache imps_cache_ref (M.insert cache_key r) + return r + + cache_key = ( homeUnitId home_unit, mb_pkg + , GWIB{ gwib_mod = wanted_mod, gwib_isBoot = is_boot }) -- | The continuation to summarise a home module if we want to find the source file -- for it and potentially compile it. summariseModuleWithSource :: HomeUnit - -> M.Map (UnitId, OsPath) ModSummary - -- ^ Map of old summaries + -> ModSummaryCache + -- ^ Cache of constructed summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Maybe (StringBuffer, UTCTime) -> HscEnv -> ModLocation -> Module -> IO SummariseResult -summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let src_fn = expectJust (ml_hs_file location) - - -- Check that it exists - -- It might have been deleted since the Finder last found it +summariseModuleWithSource home_unit summ_cache_ref is_boot maybe_buf hsc_env location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let src_fn = expectJust (ml_hs_file location) + summ_cache <- readIORef summ_cache_ref + case ml_hs_file_ospath location >>= \p -> M.lookup (moduleUnitId mod, p) summ_cache of + Just (Right (chd_summary, SummFresh)) -> + -- Fresh! just return it + pure $ FoundHome (ModuleNodeCompile chd_summary) + + Just (Left err) -> + -- Failure, don't try to summarise it again + pure $ FoundHomeWithError (moduleUnitId mod, err) + + mb_old -> do + -- Either Nothing or a potentially old summary, must check. + + -- Check that it exists + -- It might have been deleted since the Finder last found it maybe_h <- fileHashIfExists src_fn case maybe_h of -- This situation can also happen if we have found the .hs file but the -- .hs-boot file doesn't exist. Nothing -> return NotThere Just h -> do - fresult <- new_summary_cache_check location mod src_fn h + fresult <- case mb_old of + Just (Right (old_summary, SummOld)) -> + -- check the hash on the source file, and return the cached + -- summary if it hasn't changed. If the file has changed then + -- need to resummarise. + case maybe_buf of + Just (buf,_) -> + checkSummaryHash hsc_env (new_summary location mod src_fn) old_summary location (fingerprintStringBuffer buf) + Nothing -> + checkSummaryHash hsc_env (new_summary location mod src_fn) old_summary location h + Nothing -> + new_summary location mod src_fn h return $ case fresult of Left err -> FoundHomeWithError (moduleUnitId mod, err) Right ms -> FoundHome (ModuleNodeCompile ms) - where dflags = hsc_dflags hsc_env - new_summary_cache_check loc mod src_fn h - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map = - - -- check the hash on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has changed then need to resummarise. - case maybe_buf of - Just (buf,_) -> - checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf) - Nothing -> - checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h - | otherwise = new_summary loc mod src_fn h - where - src_fn_os = unsafeEncodeUtf src_fn - new_summary :: ModLocation -> Module -> FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary) new_summary location mod src_fn src_hash - = runExceptT $ do - preimps@PreprocessedImports {..} - -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP - -- See multiHomeUnits_cpp2 test - <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf - - -- NB: Despite the fact that is_boot is a top-level parameter, we - -- don't actually know coming into this function what the HscSource - -- of the module in question is. This is because we may be processing - -- this module because another module in the graph imported it: in this - -- case, we know if it's a boot or not because of the {-# SOURCE #-} - -- annotation, but we don't know if it's a signature or a regular - -- module until we actually look it up on the filesystem. - let hsc_src - | is_boot == IsBoot = HsBootFile - | isHaskellSigFilename src_fn = HsigFile - | otherwise = HsSrcFile - - when (pi_mod_name /= moduleName mod) $ - throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc - $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod) - - let instantiations = homeUnitInstantiations home_unit - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $ - throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc - $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations - - liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary - { nms_src_fn = src_fn - , nms_src_hash = src_hash - , nms_hsc_src = hsc_src - , nms_location = location - , nms_mod = mod - , nms_preimps = preimps - } + = do + res <- runExceptT $ do + preimps@PreprocessedImports {..} + -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP + -- See multiHomeUnits_cpp2 test + <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf + + -- NB: Despite the fact that is_boot is a top-level parameter, we + -- don't actually know coming into this function what the HscSource + -- of the module in question is. This is because we may be processing + -- this module because another module in the graph imported it: in this + -- case, we know if it's a boot or not because of the {-# SOURCE #-} + -- annotation, but we don't know if it's a signature or a regular + -- module until we actually look it up on the filesystem. + let hsc_src + | is_boot == IsBoot = HsBootFile + | isHaskellSigFilename src_fn = HsigFile + | otherwise = HsSrcFile + + when (pi_mod_name /= moduleName mod) $ + throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc + $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod) + + let instantiations = homeUnitInstantiations home_unit + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $ + throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc + $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_hash = src_hash + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_preimps = preimps + } + modifySummCache summ_cache_ref $ case res of + Left e -> case ml_hs_file_ospath location of + Just p -> M.insert (moduleUnitId mod, p) (Left e) + Nothing -> id + Right ms -> addModSummaryCache ms SummFresh + return res -- | Convenience named arguments for 'makeNewModSummary' only used to make -- code more readable, not exported. @@ -1508,7 +1577,6 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do hie_timestamp <- modificationTimeIfExists (ml_hie_file_ospath nms_location) bytecode_timestamp <- modificationTimeIfExists (ml_bytecode_file_ospath nms_location) extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name - (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps return $ ModSummary @@ -1522,7 +1590,6 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do , ms_srcimps = pi_srcimps , ms_textual_imps = ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) ++ - ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs) ++ pi_theimps , ms_hs_hash = nms_src_hash , ms_iface_date = hi_timestamp @@ -1568,3 +1635,92 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do let pi_srcimps = pi_srcimps' let pi_theimps = rn_imps pi_theimps' return PreprocessedImports {..} + +-------------------------------------------------------------------------------- + +-- | In a depth-first order, and starting from the given roots, traverse a +-- graph by iteratively expanding a node into a payload and a list of children +-- nodes to visit next. +-- +-- A node is NEVER visited/expanded more than once, as long as the the +-- node key @k@, computed from the node @n@, uniquely identifies that node. +-- +-- The first argument @base_map@ is the starting set of already visited nodes +-- (these nodes won't be expanded again!). +-- +-- The result is a mapping from the key of every node transitively reachable +-- from the root nodes (inclusively) to the payload returned by expanding that +-- node. The result includes the previously visited nodes given in @base_map@, +-- s.t. @dfsBuild base_map [] _ _ == base_map@. +-- +-- The @expand@ function may return 'Nothing' if it couldn't compute a payload +-- and/or children value for the given node. This makes 'dfsBuild' ignore that +-- node and continue without failure. We do not cache a "negative" result for +-- the 'Nothing', because if another node happens to expand into this one +-- again, it might well work the second time around (e.g. because of the +-- monadic context). +-- +-- Error handling and exiting early can be achieved by selecting a @Monad m@ +-- accordingly, such as @Control.Monad.Except.Except@ +-- +-- Example usage: @n@ is instanced to @DownsweepNode@, @k@ is @NodeKey@, and @v@ is @ModuleNodeEdge@. +-- +-- See also Note [Downsweep Control Flow and Caching] +dfsBuild :: (Ord k, Monad m) => Maybe (Map.Map k v) -> [n] -> (n -> k) -> (n -> m (Maybe (v,[n]))) -> m (Map.Map k v) +dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map) + where + go [] visited = pure visited + go (s:ss) visited + | k `Map.member` visited + = go ss visited + | otherwise + = do r <- expand s + case r of + Nothing -> go ss visited -- Skip! + Just (v,ns) -> + go (ns ++ ss {- todo: not use ++ here? -}) + (Map.insert k v visited) + where + k = key s + +{- +Note [Downsweep Control Flow and Caching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The control flow of downsweep is extracted into a single function `dfsBuild`, +which takes care of iteratively expanding and traversing all nodes of the +in-construction module graph necessary to build a full `ModuleGraph` at the +end. + +There are three levels of caching going on, all of which are necessary to make +sure we don't do repeated work (notably, we NEVER summarise the same module +twice). + +1. `dfsBuild` accumulates the final module graph and never revisits the + same node of the module graph. Cache is keyed by the final + `ModuleGraph`s `NodeKey`s. + +2. For Module A in home-unit u1, each import in the list of imports + needs to be *found* (call to `findImportedModuleWithIsBoot`): at this + point, we only have the `ModuleName` of the import, not the `Module`. + This *finding* is somewhat expensive, so we cache it as well + (`ImportsCache`). The cache key is the home-unit to which the module + belongs~[1], the import package qualifier, and the ModuleName. + + [1] Different home-units will have different package flags, which means + potentially different `Module` resolution for the same `ModuleName`. + +3. The most expensive operation we want to avoid is summarising a + `Module` into a `ModSummary`, which notably involves parsing the + module header from scratch. + The third cache, in essence, maps a `Module` to its `ModSummary` + (named `ModSummaryCache`). This cache upholds the invariant: we NEVER + summarise the same module twice. In practice, the cache key is the + Module's UnitId and the Source path; the reason is we need to + distinguish between `.hs` and `.hs-boot` files, as their summaries + will differ. + + Note that (2) can't guarantee this alone: Two ModuleName imports in + separate units can (and likely do) map to the same `Module`. + +See also Note [Downsweep and the ModuleGraph] +-} ===================================== compiler/GHC/Tc/Utils/Backpack.hs ===================================== @@ -291,28 +291,28 @@ implicitRequirements hsc_env normal_imports where mhome_unit = hsc_home_unit_maybe hsc_env --- | Like @implicitRequirements'@, but returns either the module name, if it is --- a free hole, or the instantiated unit the imported module is from, so that --- that instantiated unit can be processed and via the batch mod graph (rather --- than a transitive closure done here) all the free holes are still reachable. +-- | Like @implicitRequirements'@, but returns the instantiated unit the +-- imported module is from, so that that instantiated unit can be processed and +-- via the batch mod graph (rather than a transitive closure done here) all the +-- free holes are still reachable. implicitRequirementsShallow :: HscEnv -> [(ImportLevel, PkgQual, Located ModuleName)] - -> IO ([ModuleName], [InstantiatedUnit]) -implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports + -> IO [InstantiatedUnit] +implicitRequirementsShallow hsc_env normal_imports = go [] normal_imports where mhome_unit = hsc_home_unit_maybe hsc_env go acc [] = pure acc - go (accL, accR) ((_stage, mb_pkg, L _ imp):imports) = do + go accR ((_stage, mb_pkg, L _ imp):imports) = do found <- findImportedModule hsc_env imp mb_pkg let acc' = case found of Found _ mod | notHomeModuleMaybe mhome_unit mod -> case moduleUnit mod of - HoleUnit -> (moduleName mod : accL, accR) - RealUnit _ -> (accL, accR) - VirtUnit u -> (accL, u:accR) - _ -> (accL, accR) + HoleUnit -> panic "implicitRequirementsShallow: HoleUnit is unreachable through findImportedModule!" + RealUnit _ -> accR + VirtUnit u -> u:accR + _ -> accR go acc' imports -- | Given a 'Unit', make sure it is well typed. This is because ===================================== testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs ===================================== @@ -24,6 +24,7 @@ import Control.Monad.Catch (handle, throwM) import Control.Exception.Context import GHC.Driver.MakeFile import GHC.Utils.Outputable +import Data.IORef (newIORef) -- | Convert a ModuleNodeCompile to a ModuleNodeFixed convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo convertToFixed (ModuleNodeCompile ms) = @@ -151,5 +152,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + summ_cache <- liftIO $ newIORef mempty + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms ===================================== testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs ===================================== @@ -16,6 +16,7 @@ import GHC.Types.SourceFile import System.Environment import Control.Monad (void, when) import Data.Maybe (fromJust) +import Data.IORef (newIORef) import Control.Exception (ExceptionWithContext(..), SomeException) import Control.Monad.Catch (handle, throwM) import Control.Exception.Context @@ -67,7 +68,9 @@ main = do keyC = msKey msC let mkGraph s = do - ([], nodes) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed s [] + summ_cache <- newIORef mempty + imps_cache <- newIORef mempty + ([], nodes) <- downsweepFromRootNodes hsc_env summ_cache imps_cache Nothing [] True DownsweepUseFixed s [] return $ mkModuleGraph nodes graph <- liftIO $ mkGraph [ModuleNodeCompile msC] @@ -98,5 +101,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + summ_cache <- liftIO $ newIORef mempty + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms ===================================== testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs ===================================== @@ -23,6 +23,7 @@ import Control.Monad.Catch (handle, throwM) import Control.Exception.Context import GHC.Utils.Outputable import Data.List +import Data.IORef (newIORef) -- | Convert a ModuleNodeCompile to a ModuleNodeFixed convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo @@ -132,5 +133,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + summ_cache <- liftIO $ newIORef mempty + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms ===================================== testsuite/tests/splice-imports/SI35.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Unit.Module.Stage import GHC.Data.Graph.Directed.Reachability import GHC.Utils.Trace import GHC.Unit.Module.Graph +import Data.IORef (newIORef) main :: IO () main = do @@ -75,5 +76,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + summ_cache <- liftIO $ newIORef mempty + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms \ No newline at end of file ===================================== utils/check-ppr/Main.hs ===================================== @@ -18,6 +18,7 @@ import System.Environment( getArgs ) import System.Exit import System.FilePath import System.IO +import Data.IORef usage :: String usage = unlines @@ -85,7 +86,8 @@ parseOneFile libdir fileName = do let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream _ <- setSessionDynFlags dflags2 hsc_env <- getSession - mms <- liftIO $ summariseFile hsc_env (hsc_home_unit hsc_env) mempty fileName Nothing Nothing + cache <- liftIO $ newIORef mempty + mms <- liftIO $ summariseFile hsc_env (hsc_home_unit hsc_env) cache fileName Nothing Nothing case mms of Left _err -> error "parseOneFile" Right ms -> parseModule ms View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a5158e0e228b0cb0259b827101702f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a5158e0e228b0cb0259b827101702f… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0