- ghc-commits - Haskell.org

[Git][ghc/ghc][master] Revert "hadrian/build-cabal: Better respect and utilize -j"
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fc2b083f by Andreas Klebinger at 2026-03-14T05:15:14-04:00 Revert "hadrian/build-cabal: Better respect and utilize -j" This reverts commit eab3dbba79650e6046efca79133b4c0a5257613d. While it's neat this currently isn't well supported on all platforms. It's time will come, but for now I'm reverting this to avoid issues for users on slightly unconvential platforms. This will be tracked at #26977. - - - - - 1 changed file: - hadrian/build-cabal Changes: ===================================== hadrian/build-cabal ===================================== @@ -23,52 +23,9 @@ fi CABVERSTR=$("$CABAL" --numeric-version) CABVER=( ${CABVERSTR//./ } ) -THREADS="-j1" -GC_THREADS="" -SEMAPHORE="" - -echo "$@" - -# Try building hadrian in parallel. We check for -j<n>. -# If threads > 1 we pass --semaphore to allow ghc to build more than one module in parallel -# If threads > 4 we pass -qn as higher parallel gc thread counts can lead to slow downs -# We only do any of thise for cabal >= 3.14, because I don't trust older versions to handle --semaphore right -if [ "${CABVER[0]}" -gt 3 ] || [ "${CABVER[0]}" -eq 3 -a "${CABVER[1]}" -ge 14 ]; -then - - for arg in "$@"; do - case "$arg" in - -j) - GC_THREADS="-qn4" - SEMAPHORE="--semaphore" - THREADS="-j" - ;; - -j[0-9]*) - threads="${arg#-j}" - if [[ "$threads" =~ ^[0-9]+$ ]] && [ "$threads" -ne 0 ]; then - THREADS="-j${threads}" - if [ $threads -ge 4 ]; then - GC_THREADS="-qn4" - fi - if [ $threads -gt 1 ]; then - SEMAPHORE="--semaphore" - fi - fi - ;; - esac - - done - -fi - -if [ "$(uname -s)" = "FreeBSD" ]; then - # Can't rely on posix semaphore support in free bsd. - SEMAPHORE="" -fi - if [ "${CABVER[0]}" -gt 2 -o "${CABVER[0]}" -eq 2 -a "${CABVER[1]}" -ge 2 ]; then - "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" ${THREADS} ${SEMAPHORE} --ghc-options="+RTS ${GC_THREADS} -RTS" exe:hadrian + "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" -j exe:hadrian # use new-exec instead of new-run to make sure that the build-tools (alex & happy) are in PATH "$CABAL" --project-file="$PROJ" new-exec "${CABFLAGS[@]}" hadrian -- \ --directory "$PWD" \ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc2b083f9541ff29925988bdf2dbb25… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc2b083f9541ff29925988bdf2dbb25… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] ci: fix ci-images revision
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 213d2c0e by Cheng Shao at 2026-03-14T05:14:28-04:00 ci: fix ci-images revision The current ci-images revision was a commit on the WIP branch of https://gitlab.haskell.org/ghc/ci-images/-/merge_requests/183, and it's not on the current ci-images master branch. This patch fixes the image revision to use the current tip of ci-images master. - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -11,7 +11,7 @@ variables: GIT_SSL_NO_VERIFY: "1" # Commit of ghc/ci-images repository from which to pull Docker images - DOCKER_REV: 4c3454a524436623df71b5faabd24e30b0f816d5 + DOCKER_REV: 5df428b97c501f61f57587048d4bd15eba53e364 # Sequential version number of all cached things. # Bump to invalidate GitLab CI cache. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/213d2c0e5ab0bf8f879fae891a634c8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/213d2c0e5ab0bf8f879fae891a634c8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Fix missing profiling header for origin_thunk frame.
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 63ae8eb3 by Andreas Klebinger at 2026-03-14T05:13:43-04:00 Fix missing profiling header for origin_thunk frame. Fixes #27007 - - - - - 1 changed file: - rts/StgMiscClosures.cmm Changes: ===================================== rts/StgMiscClosures.cmm ===================================== @@ -47,6 +47,7 @@ import CLOSURE stg_ret_v_info; /* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */ INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, W_ info_ptr, + PROF_HDR_FIELDS(W_, p1, p2) W_ thunk_info_ptr) /* no args => explicit stack */ { View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63ae8eb38c54eaba77949b048a3621a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63ae8eb38c54eaba77949b048a3621a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] exceptions: annotate onException continuation with WhileHandling
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3774086e by Matthew Pickering at 2026-03-14T05:13:00-04:00 exceptions: annotate onException continuation with WhileHandling Before this patch, an exception thrown in the `onException` handler would loose track of where the original exception was thrown. ``` import Control.Exception main :: IO () main = failingAction `onException` failingCleanup where failingAction = throwIO (ErrorCall "outer failure") failingCleanup = throwIO (ErrorCall "cleanup failure") ``` would report ``` T28399: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: cleanup failure HasCallStack backtrace: throwIO, called at T28399.hs:<line>:<column> in <package-id>:Main ``` notice that the "outer failure" exception is not present in the error message. With this patch, any exception thrown is in the handler is annotated with WhileHandling. The resulting message looks like ``` T28399: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: cleanup failure While handling outer failure HasCallStack backtrace: throwIO, called at T28399.hs:7:22 in main:Main ``` CLC Proposal: https://github.com/haskell/core-libraries-committee/issues/397 Fixes #26759 - - - - - 9 changed files: - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - + testsuite/tests/exceptions/T26759.hs - + testsuite/tests/exceptions/T26759.stderr - + testsuite/tests/exceptions/T26759a.hs - + testsuite/tests/exceptions/T26759a.stderr - + testsuite/tests/exceptions/T26759a.stdout - testsuite/tests/exceptions/all.T Changes: ===================================== libraries/base/changelog.md ===================================== @@ -27,6 +27,7 @@ * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) + * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -203,7 +203,7 @@ tryJust p a = catchJust p (Right `fmap` a) (return . Left) -- exception raised by the computation. onException :: IO a -> IO b -> IO a onException io what = io `catchNoPropagate` \e -> do - _ <- what + _ <- annotateIO (whileHandling e) what rethrowIO (e :: ExceptionWithContext SomeException) ----------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/IO.hs ===================================== @@ -52,7 +52,7 @@ module GHC.Internal.IO ( import GHC.Internal.Base import GHC.Internal.ST import GHC.Internal.Exception -import GHC.Internal.Exception.Type (NoBacktrace(..), WhileHandling(..), HasExceptionContext, ExceptionWithContext(..)) +import GHC.Internal.Exception.Type (NoBacktrace(..), whileHandling, WhileHandling(..), HasExceptionContext, ExceptionWithContext(..)) import GHC.Internal.Show import GHC.Internal.IO.Unsafe import GHC.Internal.Unsafe.Coerce ( unsafeCoerce ) @@ -363,7 +363,7 @@ getMaskingState = IO $ \s -> onException :: IO a -> IO b -> IO a onException io what = io `catchExceptionNoPropagate` \e -> do - _ <- what + _ <- annotateIO (whileHandling e) what rethrowIO (e :: ExceptionWithContext SomeException) -- | Executes an IO computation with asynchronous ===================================== testsuite/tests/exceptions/T26759.hs ===================================== @@ -0,0 +1,10 @@ +import Control.Exception + +run :: IO () +run = failingAction `onException` failingCleanup + where + failingAction = throwIO (ErrorCall "outer failure") + failingCleanup = throwIO (ErrorCall "cleanup failure") + +main :: IO () +main = run ===================================== testsuite/tests/exceptions/T26759.stderr ===================================== @@ -0,0 +1,9 @@ +T26759: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: + +cleanup failure + +While handling outer failure + +HasCallStack backtrace: + throwIO, called at T26759.hs:7:22 in main:Main + ===================================== testsuite/tests/exceptions/T26759a.hs ===================================== @@ -0,0 +1,10 @@ +import Control.Exception + +run :: IO () +run = failingAction `onException` cleanup + where + failingAction = throwIO (ErrorCall "outer failure") + cleanup = putStrLn "cleanup" + +main :: IO () +main = run ===================================== testsuite/tests/exceptions/T26759a.stderr ===================================== @@ -0,0 +1,7 @@ +T26759a: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: + +outer failure + +HasCallStack backtrace: + throwIO, called at T26759a.hs:6:21 in main:Main + ===================================== testsuite/tests/exceptions/T26759a.stdout ===================================== @@ -0,0 +1 @@ +cleanup ===================================== testsuite/tests/exceptions/all.T ===================================== @@ -1,2 +1,3 @@ test('T25052', normal, compile_and_run, ['']) - +test('T26759', exit_code(1), compile_and_run, ['']) +test('T26759a', exit_code(1), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3774086e666f08d9800ce22a1dfc3a1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3774086e666f08d9800ce22a1dfc3a1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] configure: make $LLVMAS default to $CC when $CcLlvmBackend is YES
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a18fa3c1 by Cheng Shao at 2026-03-14T05:12:14-04:00 configure: make $LLVMAS default to $CC when $CcLlvmBackend is YES This patch changes the $LLVMAS detection logic in configure so that when it's not manually specified by the user, it defaults to $CC if $CcLlvmBackend is YES. It's a more sensible default than auto-detected clang from the environment, especially when cross-compiling, $CC as the cross target's LLVM assembler is more compatible with the use case than the system-wide clang. Fixes #26769. - - - - - 2 changed files: - configure.ac - distrib/configure.ac.in Changes: ===================================== configure.ac ===================================== @@ -542,9 +542,17 @@ FIND_LLVM_PROG([OPT], [opt], [$LlvmMinVersion], [$LlvmMaxVersion]) OptCmd="$OPT" AC_SUBST([OptCmd]) +dnl ** look to see if we have a C compiler using an llvm back end. +dnl +FP_CC_LLVM_BACKEND +AC_SUBST(CcLlvmBackend) + dnl ** Which LLVM assembler to use? dnl -------------------------------------------------------------- AC_ARG_VAR(LLVMAS,[Use as the path to LLVM's assembler (typically clang) [default=autodetect]]) +if test "x$CcLlvmBackend" = "xYES" && test -z "$LLVMAS"; then + LLVMAS="$CC" +fi FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion]) LlvmAsCmd="$LLVMAS" AC_SUBST([LlvmAsCmd]) @@ -622,11 +630,6 @@ else AC_SUBST([NeedLibatomic],[NO]) fi -dnl ** look to see if we have a C compiler using an llvm back end. -dnl -FP_CC_LLVM_BACKEND -AC_SUBST(CcLlvmBackend) - FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS]) FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAGE1],[CONF_LD_LINKER_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1]) ===================================== distrib/configure.ac.in ===================================== @@ -203,9 +203,17 @@ FIND_LLVM_PROG([OPT], [opt], [$LlvmMinVersion], [$LlvmMaxVersion]) OptCmd="$OPT" AC_SUBST([OptCmd]) +dnl ** look to see if we have a C compiler using an llvm back end. +dnl +FP_CC_LLVM_BACKEND +AC_SUBST(CcLlvmBackend) + dnl ** Which LLVM assembler to use? dnl -------------------------------------------------------------- AC_ARG_VAR(LLVMAS,[Use as the path to LLVM's assembler (typically clang) [default=autodetect]]) +if test "x$CcLlvmBackend" = "xYES" && test -z "$LLVMAS"; then + LLVMAS="$CC" +fi FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion]) LlvmAsCmd="$LLVMAS" AC_SUBST([LlvmAsCmd]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a18fa3c142a194aa9725abb004730ad… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a18fa3c142a194aa9725abb004730ad… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ci-make-install-j
by Cheng Shao (＠TerrorJack) 14 Mar '26

14 Mar '26

Cheng Shao pushed new branch wip/ci-make-install-j at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ci-make-install-j You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: configure: make $LLVMAS default to $CC when $CcLlvmBackend is YES
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8833e7d9 by Cheng Shao at 2026-03-14T00:11:41-04:00 configure: make $LLVMAS default to $CC when $CcLlvmBackend is YES This patch changes the $LLVMAS detection logic in configure so that when it's not manually specified by the user, it defaults to $CC if $CcLlvmBackend is YES. It's a more sensible default than auto-detected clang from the environment, especially when cross-compiling, $CC as the cross target's LLVM assembler is more compatible with the use case than the system-wide clang. Fixes #26769. - - - - - 53ae233d by Matthew Pickering at 2026-03-14T00:11:41-04:00 exceptions: annotate onException continuation with WhileHandling Before this patch, an exception thrown in the `onException` handler would loose track of where the original exception was thrown. ``` import Control.Exception main :: IO () main = failingAction `onException` failingCleanup where failingAction = throwIO (ErrorCall "outer failure") failingCleanup = throwIO (ErrorCall "cleanup failure") ``` would report ``` T28399: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: cleanup failure HasCallStack backtrace: throwIO, called at T28399.hs:<line>:<column> in <package-id>:Main ``` notice that the "outer failure" exception is not present in the error message. With this patch, any exception thrown is in the handler is annotated with WhileHandling. The resulting message looks like ``` T28399: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: cleanup failure While handling outer failure HasCallStack backtrace: throwIO, called at T28399.hs:7:22 in main:Main ``` CLC Proposal: https://github.com/haskell/core-libraries-committee/issues/397 Fixes #26759 - - - - - a3ac9e2a by Andreas Klebinger at 2026-03-14T00:11:42-04:00 Fix missing profiling header for origin_thunk frame. Fixes #27007 - - - - - e1118b76 by Cheng Shao at 2026-03-14T00:11:43-04:00 ci: fix ci-images revision The current ci-images revision was a commit on the WIP branch of https://gitlab.haskell.org/ghc/ci-images/-/merge_requests/183, and it's not on the current ci-images master branch. This patch fixes the image revision to use the current tip of ci-images master. - - - - - 6a4c0dcc by Andreas Klebinger at 2026-03-14T00:11:44-04:00 Revert "hadrian/build-cabal: Better respect and utilize -j" This reverts commit eab3dbba79650e6046efca79133b4c0a5257613d. While it's neat this currently isn't well supported on all platforms. It's time will come, but for now I'm reverting this to avoid issues for users on slightly unconvential platforms. This will be tracked at #26977. - - - - - 14 changed files: - .gitlab-ci.yml - configure.ac - distrib/configure.ac.in - hadrian/build-cabal - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - rts/StgMiscClosures.cmm - + testsuite/tests/exceptions/T26759.hs - + testsuite/tests/exceptions/T26759.stderr - + testsuite/tests/exceptions/T26759a.hs - + testsuite/tests/exceptions/T26759a.stderr - + testsuite/tests/exceptions/T26759a.stdout - testsuite/tests/exceptions/all.T Changes: ===================================== .gitlab-ci.yml ===================================== @@ -11,7 +11,7 @@ variables: GIT_SSL_NO_VERIFY: "1" # Commit of ghc/ci-images repository from which to pull Docker images - DOCKER_REV: 4c3454a524436623df71b5faabd24e30b0f816d5 + DOCKER_REV: 5df428b97c501f61f57587048d4bd15eba53e364 # Sequential version number of all cached things. # Bump to invalidate GitLab CI cache. ===================================== configure.ac ===================================== @@ -542,9 +542,17 @@ FIND_LLVM_PROG([OPT], [opt], [$LlvmMinVersion], [$LlvmMaxVersion]) OptCmd="$OPT" AC_SUBST([OptCmd]) +dnl ** look to see if we have a C compiler using an llvm back end. +dnl +FP_CC_LLVM_BACKEND +AC_SUBST(CcLlvmBackend) + dnl ** Which LLVM assembler to use? dnl -------------------------------------------------------------- AC_ARG_VAR(LLVMAS,[Use as the path to LLVM's assembler (typically clang) [default=autodetect]]) +if test "x$CcLlvmBackend" = "xYES" && test -z "$LLVMAS"; then + LLVMAS="$CC" +fi FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion]) LlvmAsCmd="$LLVMAS" AC_SUBST([LlvmAsCmd]) @@ -622,11 +630,6 @@ else AC_SUBST([NeedLibatomic],[NO]) fi -dnl ** look to see if we have a C compiler using an llvm back end. -dnl -FP_CC_LLVM_BACKEND -AC_SUBST(CcLlvmBackend) - FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS]) FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAGE1],[CONF_LD_LINKER_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1]) ===================================== distrib/configure.ac.in ===================================== @@ -203,9 +203,17 @@ FIND_LLVM_PROG([OPT], [opt], [$LlvmMinVersion], [$LlvmMaxVersion]) OptCmd="$OPT" AC_SUBST([OptCmd]) +dnl ** look to see if we have a C compiler using an llvm back end. +dnl +FP_CC_LLVM_BACKEND +AC_SUBST(CcLlvmBackend) + dnl ** Which LLVM assembler to use? dnl -------------------------------------------------------------- AC_ARG_VAR(LLVMAS,[Use as the path to LLVM's assembler (typically clang) [default=autodetect]]) +if test "x$CcLlvmBackend" = "xYES" && test -z "$LLVMAS"; then + LLVMAS="$CC" +fi FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion]) LlvmAsCmd="$LLVMAS" AC_SUBST([LlvmAsCmd]) ===================================== hadrian/build-cabal ===================================== @@ -23,52 +23,9 @@ fi CABVERSTR=$("$CABAL" --numeric-version) CABVER=( ${CABVERSTR//./ } ) -THREADS="-j1" -GC_THREADS="" -SEMAPHORE="" - -echo "$@" - -# Try building hadrian in parallel. We check for -j<n>. -# If threads > 1 we pass --semaphore to allow ghc to build more than one module in parallel -# If threads > 4 we pass -qn as higher parallel gc thread counts can lead to slow downs -# We only do any of thise for cabal >= 3.14, because I don't trust older versions to handle --semaphore right -if [ "${CABVER[0]}" -gt 3 ] || [ "${CABVER[0]}" -eq 3 -a "${CABVER[1]}" -ge 14 ]; -then - - for arg in "$@"; do - case "$arg" in - -j) - GC_THREADS="-qn4" - SEMAPHORE="--semaphore" - THREADS="-j" - ;; - -j[0-9]*) - threads="${arg#-j}" - if [[ "$threads" =~ ^[0-9]+$ ]] && [ "$threads" -ne 0 ]; then - THREADS="-j${threads}" - if [ $threads -ge 4 ]; then - GC_THREADS="-qn4" - fi - if [ $threads -gt 1 ]; then - SEMAPHORE="--semaphore" - fi - fi - ;; - esac - - done - -fi - -if [ "$(uname -s)" = "FreeBSD" ]; then - # Can't rely on posix semaphore support in free bsd. - SEMAPHORE="" -fi - if [ "${CABVER[0]}" -gt 2 -o "${CABVER[0]}" -eq 2 -a "${CABVER[1]}" -ge 2 ]; then - "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" ${THREADS} ${SEMAPHORE} --ghc-options="+RTS ${GC_THREADS} -RTS" exe:hadrian + "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" -j exe:hadrian # use new-exec instead of new-run to make sure that the build-tools (alex & happy) are in PATH "$CABAL" --project-file="$PROJ" new-exec "${CABFLAGS[@]}" hadrian -- \ --directory "$PWD" \ ===================================== libraries/base/changelog.md ===================================== @@ -27,6 +27,7 @@ * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) + * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -203,7 +203,7 @@ tryJust p a = catchJust p (Right `fmap` a) (return . Left) -- exception raised by the computation. onException :: IO a -> IO b -> IO a onException io what = io `catchNoPropagate` \e -> do - _ <- what + _ <- annotateIO (whileHandling e) what rethrowIO (e :: ExceptionWithContext SomeException) ----------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/IO.hs ===================================== @@ -52,7 +52,7 @@ module GHC.Internal.IO ( import GHC.Internal.Base import GHC.Internal.ST import GHC.Internal.Exception -import GHC.Internal.Exception.Type (NoBacktrace(..), WhileHandling(..), HasExceptionContext, ExceptionWithContext(..)) +import GHC.Internal.Exception.Type (NoBacktrace(..), whileHandling, WhileHandling(..), HasExceptionContext, ExceptionWithContext(..)) import GHC.Internal.Show import GHC.Internal.IO.Unsafe import GHC.Internal.Unsafe.Coerce ( unsafeCoerce ) @@ -363,7 +363,7 @@ getMaskingState = IO $ \s -> onException :: IO a -> IO b -> IO a onException io what = io `catchExceptionNoPropagate` \e -> do - _ <- what + _ <- annotateIO (whileHandling e) what rethrowIO (e :: ExceptionWithContext SomeException) -- | Executes an IO computation with asynchronous ===================================== rts/StgMiscClosures.cmm ===================================== @@ -47,6 +47,7 @@ import CLOSURE stg_ret_v_info; /* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */ INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, W_ info_ptr, + PROF_HDR_FIELDS(W_, p1, p2) W_ thunk_info_ptr) /* no args => explicit stack */ { ===================================== testsuite/tests/exceptions/T26759.hs ===================================== @@ -0,0 +1,10 @@ +import Control.Exception + +run :: IO () +run = failingAction `onException` failingCleanup + where + failingAction = throwIO (ErrorCall "outer failure") + failingCleanup = throwIO (ErrorCall "cleanup failure") + +main :: IO () +main = run ===================================== testsuite/tests/exceptions/T26759.stderr ===================================== @@ -0,0 +1,9 @@ +T26759: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: + +cleanup failure + +While handling outer failure + +HasCallStack backtrace: + throwIO, called at T26759.hs:7:22 in main:Main + ===================================== testsuite/tests/exceptions/T26759a.hs ===================================== @@ -0,0 +1,10 @@ +import Control.Exception + +run :: IO () +run = failingAction `onException` cleanup + where + failingAction = throwIO (ErrorCall "outer failure") + cleanup = putStrLn "cleanup" + +main :: IO () +main = run ===================================== testsuite/tests/exceptions/T26759a.stderr ===================================== @@ -0,0 +1,7 @@ +T26759a: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: + +outer failure + +HasCallStack backtrace: + throwIO, called at T26759a.hs:6:21 in main:Main + ===================================== testsuite/tests/exceptions/T26759a.stdout ===================================== @@ -0,0 +1 @@ +cleanup ===================================== testsuite/tests/exceptions/all.T ===================================== @@ -1,2 +1,3 @@ test('T25052', normal, compile_and_run, ['']) - +test('T26759', exit_code(1), compile_and_run, ['']) +test('T26759a', exit_code(1), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dedb4fec9b374c4f422f04d10b9395… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dedb4fec9b374c4f422f04d10b9395… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/abstract-q] 2 commits: wip: Abstract Q
by Teo Camarasu (＠teo) 14 Mar '26

14 Mar '26

Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC Commits: 81baed9d by Teo Camarasu at 2026-03-14T01:09:55+00:00 wip: Abstract Q - - - - - 3fd2d50d by Teo Camarasu at 2026-03-14T01:09:55+00:00 wip - - - - - 4 changed files: - compiler/GHC/Data/IOEnv.hs - compiler/GHC/Tc/Gen/Splice.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghci/GHCi/TH.hs Changes: ===================================== compiler/GHC/Data/IOEnv.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Data.IOEnv ( -- I/O operations IORef, newMutVar, readMutVar, writeMutVar, updMutVar, - atomicUpdMutVar, atomicUpdMutVar' + atomicUpdMutVar, atomicUpdMutVar', unliftIOEnv ) where import GHC.Prelude @@ -258,3 +258,10 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a {-# INLINE updEnvIO #-} updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env) + +unliftIOEnv :: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b +unliftIOEnv k = IOEnv $ \env -> + let + unlift :: forall a. IOEnv env a -> IO a + unlift (IOEnv m) = m env + in k unlift ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -138,6 +138,7 @@ import qualified GHC.LanguageExtensions as LangExt -- THSyntax gives access to internal functions and data types import qualified GHC.Boot.TH.Syntax as TH import qualified GHC.Boot.TH.Monad as TH +import GHC.Boot.TH.Monad (MetaHandlers(..)) import qualified GHC.Boot.TH.Ppr as TH #if defined(HAVE_INTERNAL_INTERPRETER) @@ -1139,7 +1140,7 @@ convertAnnotationWrapper fhv = do -} runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act +runQuasi (TH.Q act) = unliftIOEnv $ \runInIO -> liftIO $ act runInIO metaHandlersTcM runRemoteModFinalizers :: ThModFinalizers -> TcM () runRemoteModFinalizers (ThModFinalizers finRefs) = do @@ -1466,68 +1467,12 @@ when showing an error message. To call runQ in the Tc monad, we need to make TcM an instance of Quasi: -} -instance TH.Quasi TcM where - qNewName s = do { u <- newUnique - ; let i = toInteger (getKey u) - ; return (TH.mkNameU s i) } - - -- 'msg' is forced to ensure exceptions don't escape, - -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg - qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg - - qLocation :: TcM TH.Loc - qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; r <- case l of - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - RealSrcSpan s _ -> return s - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitString (moduleUnit m) - , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) - , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } - - qLookupName = lookupName - qReify = reify - qReifyFixity nm = lookupThName nm >>= reifyFixity - qReifyType = reifyTypeOfThing - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness nm = do { nm' <- lookupThName nm - ; dc <- tcLookupDataCon nm' - ; let bangs = dataConImplBangs dc - ; return (map reifyDecidedStrictness bangs) } - - -- For qRecover, discard error messages if - -- the recovery action is chosen. Otherwise - -- we'll only fail higher up. - qRecover recover main = tryTcDiscardingErrs recover main - - qGetPackageRoot = do - dflags <- getDynFlags - return $ fromMaybe "." (workingDirectory dflags) - - qAddDependentFile fp = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fp:dep_files) - - qAddDependentDirectory dp = do - ref <- fmap tcg_dependent_dirs getGblEnv - dep_dirs <- readTcRef ref - writeTcRef ref (dp:dep_dirs) - - qAddTempFile suffix = do - dflags <- getDynFlags - logger <- getLogger - tmpfs <- hsc_tmpfs <$> getTopEnv - liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix - - qAddTopDecls thds = do +report :: Bool -> [Char] -> TcM () +report True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg +report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg + +addTopDecls :: [TH.Dec] -> TcM () +addTopDecls thds = do exts <- fmap extensionFlags getDynFlags l <- getSrcSpanM th_origin <- getThSpliceOrigin @@ -1555,52 +1500,13 @@ instance TH.Quasi TcM where bindName :: RdrName -> TcM () bindName (Exact n) = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) + } bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name - qAddForeignFilePath lang fp = do - var <- fmap tcg_th_foreign_files getGblEnv - updTcRef var ((lang, fp) :) - - qAddModFinalizer fin = do - r <- liftIO $ mkRemoteRef fin - fref <- liftIO $ mkForeignRef r (freeRemoteRef r) - addModFinalizerRef fref - - qAddCorePlugin plugin = do - hsc_env <- getTopEnv - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) - let err = TcRnTHError $ AddInvalidCorePlugin plugin - case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err - _ -> return () - th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv - updTcRef th_coreplugins_var (plugin:) - - qGetQ :: forall a. Typeable a => TcM (Maybe a) - qGetQ = do - th_state_var <- fmap tcg_th_state getGblEnv - th_state <- readTcRef th_state_var - -- See #10596 for why we use a scoped type variable here. - return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) - - qPutQ x = do - th_state_var <- fmap tcg_th_state getGblEnv - updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) - - qIsExtEnabled = xoptM - - qExtsEnabled = - EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv - - qPutDoc doc_loc s = do +putDoc :: TH.DocLoc -> String -> TcM () +putDoc doc_loc s = do th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc @@ -1622,15 +1528,129 @@ instance TH.Quasi TcM where checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n checkLocalName ModuleDoc = pure True - - qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc - qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc - qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i - qGetDoc TH.ModuleDoc = do +getDoc :: TH.DocLoc -> TcM (Maybe String) +getDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc +getDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc +getDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i +getDoc TH.ModuleDoc = do df <- getDynFlags docs <- getGblEnv >>= extractDocs df return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs)) +getQ :: forall a. Typeable a => TcM (Maybe a) +getQ = do + th_state_var <- fmap tcg_th_state getGblEnv + th_state <- readTcRef th_state_var + -- See #10596 for why we use a scoped type variable here. + return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) + +location :: TcM TH.Loc +location = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s _ -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = unitString (moduleUnit m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + +metaHandlersTcM :: TH.MetaHandlers TcM +metaHandlersTcM = TH.MetaHandlers { + mNewName = \s -> do { u <- newUnique + ; let i = toInteger (getKey u) + ; return (TH.mkNameU s i) } + + -- 'msg' is forced to ensure exceptions don't escape, + -- see Note [Exceptions in TH] + , mReport = report + + , mLocation = location + + , mLookupName = lookupName + , mReify = reify + , mReifyFixity = \nm -> lookupThName nm >>= reifyFixity + , mReifyType = reifyTypeOfThing + , mReifyInstances = reifyInstances + , mReifyRoles = reifyRoles + , mReifyAnnotations = reifyAnnotations + , mReifyModule = reifyModule + , mReifyConStrictness = \nm -> do { nm' <- lookupThName nm + ; dc <- tcLookupDataCon nm' + ; let bangs = dataConImplBangs dc + ; return (map reifyDecidedStrictness bangs) } + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. + -- NB: extremely subtle!!! TODO: write up note + -- tryTcDiscardingErrs manipulates the reader env so we need to be careful we don't sneak in the outside env + , mRecover = \recover main -> tryTcDiscardingErrs (runQuasi recover) (runQuasi main) + + , mGetPackageRoot = do + dflags <- getDynFlags + return $ fromMaybe "." (workingDirectory dflags) + + , mAddDependentFile = \fp -> do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + , mAddDependentDirectory = \dp -> do + ref <- fmap tcg_dependent_dirs getGblEnv + dep_dirs <- readTcRef ref + writeTcRef ref (dp:dep_dirs) + + , mAddTempFile = \suffix -> do + dflags <- getDynFlags + logger <- getLogger + tmpfs <- hsc_tmpfs <$> getTopEnv + liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix + + , mAddTopDecls = addTopDecls + + , mAddForeignFilePath = \lang fp -> do + var <- fmap tcg_th_foreign_files getGblEnv + updTcRef var ((lang, fp) :) + + , mAddModFinalizer = \fin -> do + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref + + , mAddCorePlugin = \plugin -> do + hsc_env <- getTopEnv + let fc = hsc_FC hsc_env + let home_unit = hsc_home_unit hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) + let err = TcRnTHError $ AddInvalidCorePlugin plugin + case r of + Found {} -> addErr err + FoundMultiple {} -> addErr err + _ -> return () + th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv + updTcRef th_coreplugins_var (plugin:) + + , mGetQ = getQ + + , mPutQ = \x -> do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + + , mIsExtEnabled = xoptM + + , mExtsEnabled = + EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + + , mPutDoc = putDoc + + , mGetDoc = getDoc + } + -- | Looks up documentation for a declaration in first the current module, -- otherwise tries to find it in another module via 'hscGetModuleInterface'. lookupDeclDoc :: Name -> TcM (Maybe String) @@ -1795,7 +1815,7 @@ runTH ty fhv = do -- Remote GHCi, see Note [Remote Template Haskell] in -- libraries/ghci/GHCi/TH.hs. rstate <- getTHState inst - loc <- TH.qLocation + loc <- location -- run a remote TH request r <- liftIO $ withForeignRef rstate $ \state_hv -> @@ -1911,32 +1931,32 @@ wrapTHResult tcm = do handleTHMessage :: THMessage a -> TcM a handleTHMessage msg = case msg of - NewName a -> wrapTHResult $ TH.qNewName a - Report b str -> wrapTHResult $ TH.qReport b str - LookupName b str -> wrapTHResult $ TH.qLookupName b str - Reify n -> wrapTHResult $ TH.qReify n - ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n - ReifyType n -> wrapTHResult $ TH.qReifyType n - ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts - ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n + NewName a -> wrapTHResult $ runQuasi $ TH.newName a + Report b str -> wrapTHResult $ runQuasi $ TH.report b str + LookupName b str -> wrapTHResult $ runQuasi $ TH.lookupName b str + Reify n -> wrapTHResult $ runQuasi $ TH.reify n + ReifyFixity n -> wrapTHResult $ runQuasi $ TH.reifyFixity n + ReifyType n -> wrapTHResult $ runQuasi $ TH.reifyType n + ReifyInstances n ts -> wrapTHResult $ runQuasi $ TH.reifyInstances n ts + ReifyRoles n -> wrapTHResult $ runQuasi $ TH.reifyRoles n ReifyAnnotations lookup tyrep -> wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) - ReifyModule m -> wrapTHResult $ TH.qReifyModule m - ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm - GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot - AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f - AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d - AddTempFile s -> wrapTHResult $ TH.qAddTempFile s + ReifyModule m -> wrapTHResult $ runQuasi $ TH.reifyModule m + ReifyConStrictness nm -> wrapTHResult $ runQuasi $ TH.reifyConStrictness nm + GetPackageRoot -> wrapTHResult $ runQuasi $ TH.getPackageRoot + AddDependentFile f -> wrapTHResult $ runQuasi $ TH.addDependentFile f + AddDependentDirectory d -> wrapTHResult $ runQuasi $ TH.addDependentDirectory d + AddTempFile s -> wrapTHResult $ runQuasi $ TH.addTempFile s AddModFinalizer r -> do interp <- hscInterp <$> getTopEnv wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef - AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str - AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs - AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str - IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext - ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled - PutDoc l s -> wrapTHResult $ TH.qPutDoc l s - GetDoc l -> wrapTHResult $ TH.qGetDoc l + AddCorePlugin str -> wrapTHResult $ runQuasi $ TH.addCorePlugin str + AddTopDecls decs -> wrapTHResult $ runQuasi $ TH.addTopDecls decs + AddForeignFilePath lang str -> wrapTHResult $ runQuasi $ TH.addForeignFilePath lang str + IsExtEnabled ext -> wrapTHResult $ runQuasi $ TH.isExtEnabled ext + ExtsEnabled -> wrapTHResult $ runQuasi $ TH.extsEnabled + PutDoc l s -> wrapTHResult $ runQuasi $ TH.putDoc l s + GetDoc l -> wrapTHResult $ runQuasi $ TH.getDoc l FailIfErrs -> wrapTHResult failIfErrsM _ -> panic ("handleTHMessage: unexpected message " ++ show msg) ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Internal.TH.Syntax ----------------------------------------------------- class (MonadIO m, MonadFail m) => Quasi m where + qRunQ :: Q a -> m a -- | Fresh names. See 'newName'. qNewName :: String -> m Name @@ -149,6 +150,7 @@ class (MonadIO m, MonadFail m) => Quasi m where -- type environment, so reification isn't going to -- work. instance Quasi IO where + qRunQ (Q m) = m id metaHandlersIO qNewName = newNameIO qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) @@ -180,9 +182,124 @@ instance Quasi IO where qGetDoc _ = badIO "getDoc" qAddDependentDirectory _ = badIO "AddDependentDirectory" +metaHandlersIO :: MetaHandlers IO +metaHandlersIO = MetaHandlers { + mNewName = newNameIO + , mReport = \b msg -> + if b then + hPutStrLn stderr ("Template Haskell error: " ++ msg) + else + hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above? + , mLookupName = \ _ _ -> badIO "lookupName" + , mReify = \_ -> badIO "reify" + , mReifyFixity = \_ -> badIO "reifyFixity" + , mReifyType = \_ -> badIO "reifyFixity" + , mReifyInstances = \_ _ -> badIO "reifyInstances" + , mReifyRoles = \_ -> badIO "reifyRoles" + , mReifyAnnotations = \_ -> badIO "reifyAnnotations" + , mReifyModule = \_ -> badIO "reifyModule" + , mReifyConStrictness = \_ -> badIO "reifyConStrictness" + , mLocation = badIO "currentLocation" + , mRecover = \_ _ -> badIO "recover" -- Maybe we could fix this? + , mGetPackageRoot = badIO "getProjectRoot" + , mAddDependentFile = \_ -> badIO "addDependentFile" + , mAddTempFile = \_ -> badIO "addTempFile" + , mAddTopDecls = \_ -> badIO "addTopDecls" + , mAddForeignFilePath = \_ _ -> badIO "addForeignFilePath" + , mAddModFinalizer = \_ -> badIO "addModFinalizer" + , mAddCorePlugin = \_ -> badIO "addCorePlugin" + , mGetQ = badIO "getQ" + , mPutQ = \_ -> badIO "putQ" + , mIsExtEnabled = \_ -> badIO "isExtEnabled" + , mExtsEnabled = badIO "extsEnabled" + , mPutDoc = \_ _ -> badIO "putDoc" + , mGetDoc = \_ -> badIO "getDoc" + , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory" + } + instance Quote IO where newName = newNameIO +data MetaHandlers m = MetaHandlers { + -- | Fresh names. See 'newName'. + mNewName :: String -> m Name + + ------- Error reporting and recovery ------- + -- | Report an error (True) or warning (False) + -- ...but carry on; use 'fail' to stop. See 'report'. + , mReport :: Bool -> String -> m () + + -- | See 'recover'. + , mRecover :: forall a. Q a -- ^ the error handler + -> Q a -- ^ action which may fail + -> m a -- ^ Recover from the monadic 'fail' + + ------- Inspect the type-checker's environment ------- + -- | True <=> type namespace, False <=> value namespace. See 'lookupName'. + , mLookupName :: Bool -> String -> m (Maybe Name) + -- | See 'reify'. + , mReify :: Name -> m Info + -- | See 'reifyFixity'. + , mReifyFixity :: Name -> m (Maybe Fixity) + -- | See 'reifyType'. + , mReifyType :: Name -> m Type + -- | Is (n tys) an instance? Returns list of matching instance Decs (with + -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'. + , mReifyInstances :: Name -> [Type] -> m [Dec] + -- | See 'reifyRoles'. + , mReifyRoles :: Name -> m [Role] + -- | See 'reifyAnnotations'. + , mReifyAnnotations :: forall a. Data a => AnnLookup -> m [a] + -- | See 'reifyModule'. + , mReifyModule :: Module -> m ModuleInfo + -- | See 'reifyConStrictness'. + , mReifyConStrictness :: Name -> m [DecidedStrictness] + + -- | See 'location'. + , mLocation :: m Loc + + -- | See 'getPackageRoot'. + , mGetPackageRoot :: m FilePath + + -- | See 'addDependentFile'. + , mAddDependentFile :: FilePath -> m () + + -- | See 'addDependentDirectory'. + , mAddDependentDirectory :: FilePath -> m () + + -- | See 'addTempFile'. + , mAddTempFile :: String -> m FilePath + + -- | See 'addTopDecls'. + , mAddTopDecls :: [Dec] -> m () + + -- | See 'addForeignFilePath'. + , mAddForeignFilePath :: ForeignSrcLang -> String -> m () + + -- | See 'addModFinalizer'. + , mAddModFinalizer :: Q () -> m () + + -- | See 'addCorePlugin'. + , mAddCorePlugin :: String -> m () + + -- | See 'getQ'. + , mGetQ :: forall a. Typeable a => m (Maybe a) + + -- | See 'putQ'. + , mPutQ :: forall a. Typeable a => a -> m () + + -- | See 'isExtEnabled'. + , mIsExtEnabled :: Extension -> m Bool + -- | See 'extsEnabled'. + , mExtsEnabled :: m [Extension] + + -- | See 'putDoc'. + , mPutDoc :: DocLoc -> String -> m () + -- | See 'getDoc'. + , mGetDoc :: DocLoc -> m (Maybe String) + } + + newNameIO :: String -> IO Name newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x)) ; pure (mkNameU s n) } @@ -213,7 +330,7 @@ counter = unsafePerformIO (newIORef 0) -- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle), -- providing an abstract interface for the user which is later concretely -- fufilled by an concrete 'Quasi' instance, internal to GHC. -newtype Q a = Q { unQ :: forall m. Quasi m => m a } +newtype Q a = Q { unQ :: forall m. (forall x. m x -> IO x) -> MetaHandlers m -> IO a } -- | \"Runs\" the 'Q' monad. Normal users of Template Haskell -- should not need this function, as the splice brackets @$( ... )@ @@ -227,22 +344,22 @@ newtype Q a = Q { unQ :: forall m. Quasi m => m a } -- simply fail at runtime. Indeed, the only operations guaranteed to succeed -- are 'newName', 'runIO', 'reportError' and 'reportWarning'. runQ :: Quasi m => Q a -> m a -runQ (Q m) = m +runQ = qRunQ instance Monad Q where - Q m >>= k = Q (m >>= \x -> unQ (k x)) + Q m >>= k = Q $ \r h -> (m r h >>= \x -> unQ (k x) r h) (>>) = (*>) instance MonadFail Q where - fail s = report True s >> Q (fail "Q monad failure") + fail s = report True s >> Q (\_ _ -> fail "Q monad failure") instance Functor Q where - fmap f (Q x) = Q (fmap f x) + fmap f (Q x) = Q $ \r h -> fmap f (x r h) instance Applicative Q where - pure x = Q (pure x) - Q f <*> Q x = Q (f <*> x) - Q m *> Q n = Q (m *> n) + pure x = Q $ \_ _ -> pure x + Q f <*> Q x = Q $ \r h -> (f r h <*> x r h) + Q m *> Q n = Q $ \r h -> (m r h *> n r h) -- | @since 2.17.0.0 instance Semigroup a => Semigroup (Q a) where @@ -311,8 +428,17 @@ class Monad m => Quote m where -} newName :: String -> m Name +runHandler :: (forall m. MetaHandlers m -> m a) -> Q a +runHandler op = Q $ \r h -> r (op h) + +runHandler1 :: (forall m. MetaHandlers m -> a -> m b) -> a -> Q b +runHandler1 op = \x -> Q $ \r h -> r (op h x) + +runHandler2 :: (forall m. MetaHandlers m -> a -> b -> m c) -> a -> b -> Q c +runHandler2 op = \x y -> Q $ \r h -> r (op h x y) + instance Quote Q where - newName s = Q (qNewName s) + newName = runHandler1 mNewName ----------------------------------------------------- -- @@ -510,7 +636,7 @@ joinCode = flip bindCode id -- | Report an error (True) or warning (False), -- but carry on; use 'fail' to stop. report :: Bool -> String -> Q () -report b s = Q (qReport b s) +report b s = runHandler2 mReport b s {-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6 -- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'. @@ -525,20 +651,20 @@ reportWarning = report False recover :: Q a -- ^ handler to invoke on failure -> Q a -- ^ computation to run -> Q a -recover (Q r) (Q m) = Q (qRecover r m) +recover rec main = Q $ \r h -> r $ mRecover h rec main -- We don't export lookupName; the Bool isn't a great API -- Instead we export lookupTypeName, lookupValueName lookupName :: Bool -> String -> Q (Maybe Name) -lookupName ns s = Q (qLookupName ns s) +lookupName ns s = runHandler2 mLookupName ns s -- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. lookupTypeName :: String -> Q (Maybe Name) -lookupTypeName s = Q (qLookupName True s) +lookupTypeName s = runHandler2 mLookupName True s -- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. lookupValueName :: String -> Q (Maybe Name) -lookupValueName s = Q (qLookupName False s) +lookupValueName s = runHandler2 mLookupName False s {- Note [Name lookup] @@ -613,7 +739,7 @@ To ensure we get information about @D@-the-value, use 'lookupValueName': and to get information about @D@-the-type, use 'lookupTypeName'. -} reify :: Name -> Q Info -reify v = Q (qReify v) +reify v = runHandler1 mReify v {- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then @@ -622,7 +748,7 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then 'Nothing', so you may assume @bar@ has 'defaultFixity'. -} reifyFixity :: Name -> Q (Maybe Fixity) -reifyFixity nm = Q (qReifyFixity nm) +reifyFixity nm = runHandler1 mReifyFixity nm {- | @reifyType nm@ attempts to find the type or kind of @nm@. For example, @reifyType 'not@ returns @Bool -> Bool@, and @@ -630,7 +756,7 @@ reifyFixity nm = Q (qReifyFixity nm) This works even if there's no explicit signature and the type or kind is inferred. -} reifyType :: Name -> Q Type -reifyType nm = Q (qReifyType nm) +reifyType nm = runHandler1 mReifyType nm {- | Template Haskell is capable of reifying information about types and terms defined in previous declaration groups. Top-level declaration splices break up @@ -722,7 +848,7 @@ has some discussion around this. -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] -reifyInstances cls tys = Q (qReifyInstances cls tys) +reifyInstances cls tys = runHandler2 mReifyInstances cls tys {- | @reifyRoles nm@ returns the list of roles associated with the parameters (both visible and invisible) of @@ -741,20 +867,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i the role of the invisible @k@ parameter. Kind parameters are always nominal. -} reifyRoles :: Name -> Q [Role] -reifyRoles nm = Q (qReifyRoles nm) +reifyRoles nm = runHandler1 mReifyRoles nm -- | @reifyAnnotations target@ returns the list of annotations -- associated with @target@. Only the annotations that are -- appropriately typed is returned. So if you have @Int@ and @String@ -- annotations for the same target, you have to call this function twice. reifyAnnotations :: Data a => AnnLookup -> Q [a] -reifyAnnotations an = Q (qReifyAnnotations an) +reifyAnnotations an = runHandler1 mReifyAnnotations an -- | @reifyModule mod@ looks up information about module @mod@. To -- look up the current module, call this function with the return -- value of 'Language.Haskell.TH.Lib.thisModule'. reifyModule :: Module -> Q ModuleInfo -reifyModule m = Q (qReifyModule m) +reifyModule m = runHandler1 mReifyModule m -- | @reifyConStrictness nm@ looks up the strictness information for the fields -- of the constructor with the name @nm@. Note that the strictness information @@ -769,7 +895,7 @@ reifyModule m = Q (qReifyModule m) -- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the -- @-XStrictData@ language extension was enabled. reifyConStrictness :: Name -> Q [DecidedStrictness] -reifyConStrictness n = Q (qReifyConStrictness n) +reifyConStrictness n = runHandler1 mReifyConStrictness n -- | Is the list of instances returned by 'reifyInstances' nonempty? -- @@ -782,7 +908,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys -- | The location at which this computation is spliced. location :: Q Loc -location = Q qLocation +location = runHandler mLocation -- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad. -- Take care: you are guaranteed the ordering of calls to 'runIO' within @@ -792,7 +918,7 @@ location = Q qLocation -- necessarily flushed when the compiler finishes running, so you should -- flush them yourself. runIO :: IO a -> Q a -runIO m = Q (qRunIO m) +runIO m = Q $ \_ _ -> m -- | Get the package root for the current package which is being compiled. -- This can be set explicitly with the -package-root flag but is normally @@ -804,7 +930,7 @@ runIO m = Q (qRunIO m) -- change directory when compiling files but instead set the -package-root flag -- appropriately. getPackageRoot :: Q FilePath -getPackageRoot = Q qGetPackageRoot +getPackageRoot = runHandler mGetPackageRoot -- | Record external directories that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -823,7 +949,7 @@ getPackageRoot = Q qGetPackageRoot -- * The state of the directory is read at the interface generation time, -- not at the time of the function call. addDependentDirectory :: FilePath -> Q () -addDependentDirectory dp = Q (qAddDependentDirectory dp) +addDependentDirectory dp = runHandler1 mAddDependentDirectory dp -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -837,17 +963,17 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp) -- -- * The dependency is based on file content, not a modification time addDependentFile :: FilePath -> Q () -addDependentFile fp = Q (qAddDependentFile fp) +addDependentFile fp = runHandler1 mAddDependentFile fp -- | Obtain a temporary file path with the given suffix. The compiler will -- delete this file after compilation. addTempFile :: String -> Q FilePath -addTempFile suffix = Q (qAddTempFile suffix) +addTempFile suffix = runHandler1 mAddTempFile suffix -- | Add additional top-level declarations. The added declarations will be type -- checked along with the current declaration group. addTopDecls :: [Dec] -> Q () -addTopDecls ds = Q (qAddTopDecls ds) +addTopDecls ds = runHandler1 mAddTopDecls ds -- | Same as 'addForeignSource', but expects to receive a path pointing to the -- foreign file instead of a 'String' of its contents. Consider using this in @@ -856,7 +982,7 @@ addTopDecls ds = Q (qAddTopDecls ds) -- This is a good alternative to 'addForeignSource' when you are trying to -- directly link in an object file. addForeignFilePath :: ForeignSrcLang -> FilePath -> Q () -addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) +addForeignFilePath lang fp = runHandler2 mAddForeignFilePath lang fp -- | Add a finalizer that will run in the Q monad after the current module has -- been type checked. This only makes sense when run within a top-level splice. @@ -865,7 +991,7 @@ addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) -- 'reify' is able to find the local definitions when executed inside the -- finalizer. addModFinalizer :: Q () -> Q () -addModFinalizer act = Q (qAddModFinalizer (unQ act)) +addModFinalizer act = runHandler1 mAddModFinalizer act -- | Adds a core plugin to the compilation pipeline. -- @@ -875,7 +1001,7 @@ addModFinalizer act = Q (qAddModFinalizer (unQ act)) -- to tell the compiler that we needed to compile first a plugin module in the -- current package. addCorePlugin :: String -> Q () -addCorePlugin plugin = Q (qAddCorePlugin plugin) +addCorePlugin plugin = runHandler1 mAddCorePlugin plugin -- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to -- a type-indexed finite map. That is, @@ -889,20 +1015,20 @@ addCorePlugin plugin = Q (qAddCorePlugin plugin) -- Note that the state is local to the Haskell module in which the Template -- Haskell expression is executed. getQ :: Typeable a => Q (Maybe a) -getQ = Q qGetQ +getQ = runHandler mGetQ -- | Replace the state in the 'Q' monad. Note that the state is local to the -- Haskell module in which the Template Haskell expression is executed. putQ :: Typeable a => a -> Q () -putQ x = Q (qPutQ x) +putQ x = runHandler1 mPutQ x -- | Determine whether the given language extension is enabled in the 'Q' monad. isExtEnabled :: Extension -> Q Bool -isExtEnabled ext = Q (qIsExtEnabled ext) +isExtEnabled ext = runHandler1 mIsExtEnabled ext -- | List all enabled language extensions. extsEnabled :: Q [Extension] -extsEnabled = Q qExtsEnabled +extsEnabled = runHandler mExtsEnabled -- | Add Haddock documentation to the specified location. This will overwrite -- any documentation at the location if it already exists. This will reify the @@ -921,19 +1047,20 @@ extsEnabled = Q qExtsEnabled -- Adding documentation to anything outside of the current module will cause an -- error. putDoc :: DocLoc -> String -> Q () -putDoc t s = Q (qPutDoc t s) +putDoc t s = runHandler2 mPutDoc t s -- | Retrieves the Haddock documentation at the specified location, if one -- exists. -- It can be used to read documentation on things defined outside of the current -- module, provided that those modules were compiled with the @-haddock@ flag. getDoc :: DocLoc -> Q (Maybe String) -getDoc n = Q (qGetDoc n) +getDoc n = runHandler1 mGetDoc n instance MonadIO Q where liftIO = runIO instance Quasi Q where + qRunQ = id qNewName = newName qReport = report qRecover = recover ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -163,56 +163,67 @@ ghcCmd m = GHCiQ $ \s -> do instance MonadIO GHCiQ where liftIO m = GHCiQ $ \s -> fmap (,s) m -instance TH.Quasi GHCiQ where - qNewName str = ghcCmd (NewName str) - qReport isError msg = ghcCmd (Report isError msg) - - -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice - qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do - remoteTHCall (qsPipe s) StartRecover - e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s - remoteTHCall (qsPipe s) (EndRecover (isLeft e)) - case e of - Left GHCiQException{} -> h s - Right r -> return r - qLookupName isType occ = ghcCmd (LookupName isType occ) - qReify name = ghcCmd (Reify name) - qReifyFixity name = ghcCmd (ReifyFixity name) - qReifyType name = ghcCmd (ReifyType name) - qReifyInstances name tys = ghcCmd (ReifyInstances name tys) - qReifyRoles name = ghcCmd (ReifyRoles name) - -- To reify annotations, we send GHC the AnnLookup and also the -- TypeRep of the thing we're looking for, to avoid needing to -- serialize irrelevant annotations. - qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a] - qReifyAnnotations lookup = +reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a] +reifyAnnotations lookup = map (deserializeWithData . B.unpack) <$> ghcCmd (ReifyAnnotations lookup typerep) where typerep = typeOf (undefined :: a) - qReifyModule m = ghcCmd (ReifyModule m) - qReifyConStrictness name = ghcCmd (ReifyConStrictness name) - qLocation = fromMaybe noLoc . qsLocation <$> getState - qGetPackageRoot = ghcCmd GetPackageRoot - qAddDependentFile file = ghcCmd (AddDependentFile file) - qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir) - qAddTempFile suffix = ghcCmd (AddTempFile suffix) - qAddTopDecls decls = ghcCmd (AddTopDecls decls) - qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp) - qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>= +-- TODO: !!! +-- This is wrong because it will discard any updates to the state. +-- What I should do instead is refactor GHCiQ first (!) to use an IORef for state, and then save/restore that. +runQinGHCiQ :: TH.Q a -> GHCiQ a +runQinGHCiQ (TH.Q m) = GHCiQ $ \s -> (,s) <$> m (runInIO s) metaHandlersGHCiQ + where + runInIO :: QState -> GHCiQ a -> IO a + runInIO s (GHCiQ m) = fst <$> m s + +metaHandlersGHCiQ = TH.MetaHandlers { + mNewName = \str -> ghcCmd (NewName str) + , mReport = \isError msg -> ghcCmd (Report isError msg) + + -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice + , mRecover = \h a -> GHCiQ $ \s -> mask $ \unmask -> do + remoteTHCall (qsPipe s) StartRecover + e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) s -- TODO: simplify + remoteTHCall (qsPipe s) (EndRecover (isLeft e)) + case e of + Left GHCiQException{} -> runGHCiQ (runQinGHCiQ h) s -- TODO: simplify + Right r -> return r + , mLookupName = \isType occ -> ghcCmd (LookupName isType occ) + , mReify = \name -> ghcCmd (Reify name) + , mReifyFixity = \name -> ghcCmd (ReifyFixity name) + , mReifyType = \name -> ghcCmd (ReifyType name) + , mReifyInstances = \name tys -> ghcCmd (ReifyInstances name tys) + , mReifyRoles = \name -> ghcCmd (ReifyRoles name) + + , mReifyAnnotations = reifyAnnotations + , mReifyModule = \m -> ghcCmd (ReifyModule m) + , mReifyConStrictness = \name -> ghcCmd (ReifyConStrictness name) + , mLocation = fromMaybe noLoc . qsLocation <$> getState + , mGetPackageRoot = ghcCmd GetPackageRoot + , mAddDependentFile = \file -> ghcCmd (AddDependentFile file) + , mAddDependentDirectory = \dir -> ghcCmd (AddDependentDirectory dir) + , mAddTempFile = \suffix -> ghcCmd (AddTempFile suffix) + , mAddTopDecls = \decls -> ghcCmd (AddTopDecls decls) + , mAddForeignFilePath = \lang fp -> ghcCmd (AddForeignFilePath lang fp) + , mAddModFinalizer = \fin -> GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>= ghcCmd . AddModFinalizer - qAddCorePlugin str = ghcCmd (AddCorePlugin str) - qGetQ = GHCiQ $ \s -> + , mAddCorePlugin = \str -> ghcCmd (AddCorePlugin str) + , mGetQ = GHCiQ $ \s -> let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m in return (lookup (qsMap s), s) - qPutQ k = GHCiQ $ \s -> + , mPutQ = \k -> GHCiQ $ \s -> return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) - qIsExtEnabled x = ghcCmd (IsExtEnabled x) - qExtsEnabled = ghcCmd ExtsEnabled - qPutDoc l s = ghcCmd (PutDoc l s) - qGetDoc l = ghcCmd (GetDoc l) + , mIsExtEnabled = \x -> ghcCmd (IsExtEnabled x) + , mExtsEnabled = ghcCmd ExtsEnabled + , mPutDoc = \l s -> ghcCmd (PutDoc l s) + , mGetDoc = \l -> ghcCmd (GetDoc l) +} -- | The implementation of the 'StartTH' message: create -- a new IORef QState, and return a RemoteRef to it. @@ -231,7 +242,7 @@ runModFinalizerRefs pipe rstate qrefs = do qs <- mapM localRef qrefs qstateref <- localRef rstate qstate <- readIORef qstateref - _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe } + _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate { qsPipe = pipe } return () -- | The implementation of the 'RunTH' message @@ -269,6 +280,6 @@ runTHQ pipe rstate mb_loc ghciq = do qstateref <- localRef rstate qstate <- readIORef qstateref let st = qstate { qsLocation = mb_loc, qsPipe = pipe } - (r,new_state) <- runGHCiQ (TH.runQ ghciq) st + (r,new_state) <- runGHCiQ (runQinGHCiQ ghciq) st writeIORef qstateref new_state return $! LB.toStrict (runPut (put r)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/857149f67c75bf2a4fd2b59f377526… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/857149f67c75bf2a4fd2b59f377526… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/tc-expand] wibbles
by Apoorv Ingle (＠ani) 14 Mar '26

14 Mar '26

Apoorv Ingle pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC Commits: 3b036900 by Apoorv Ingle at 2026-03-13T18:34:40-05:00 wibbles - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Tc.Gen.App , tcExprSigma , tcExprPrag ) where -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyLExprNC ) import GHC.Hs @@ -570,7 +570,7 @@ tcValArg do_ql _ _ (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w tcValArg _ _ _ (EWrap ew) = return (EWrap ew) tcValArg do_ql pos (fun, fun_lspan) (EValArg { ea_loc_span = lspan - , ea_arg = larg@(L arg_loc arg) + , ea_arg = larg@(L arg_loc _) , ea_arg_ty = sc_arg_ty }) = addArgCtxt pos (fun, fun_lspan) larg $ do { -- Crucial step: expose QL results before checking exp_arg_ty @@ -596,11 +596,11 @@ tcValArg do_ql pos (fun, fun_lspan) (EValArg { ea_loc_span = lspan -- Now check the argument ; arg' <- tcScalingUsage mult $ - tcPolyExpr arg (mkCheckExpType exp_arg_ty) + tcPolyLExprNC larg (mkCheckExpType exp_arg_ty) ; traceTc "tcValArg" $ vcat [ ppr arg' , text "}" ] ; return (EValArg { ea_loc_span = lspan - , ea_arg = L arg_loc arg' + , ea_arg = arg' , ea_arg_ty = noExtField }) } tcValArg _ pos (fun, fun_lspan) (EValArgQL { ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -123,30 +123,11 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType tcPolyLExpr (L loc expr) res_ty = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] - do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty - ; e <- - mb_add_xexpr_wrap (ExprCtxt expr) did_expand $ mb_add_ctxt ctxt (locA loc') expanded_expr $ - case mb_ret_ty of - Nothing -> tcPolyExpr expanded_expr res_ty - Just ds_res_ty -> do expr' <- tcPolyExpr expanded_expr (Check ds_res_ty) - tcWrapResult expr expr' ds_res_ty res_ty - ; return (L loc' e) - } - where - mb_add_ctxt :: Maybe HsCtxt -> SrcSpan -> HsExpr GhcRn -> TcM a -> TcM a - mb_add_ctxt Nothing _ _ thing_inside - = thing_inside - mb_add_ctxt (Just ctxt) loc expanded_expr thing_inside - = addExpansionErrCtxt ctxt $ - addLExprCtxt loc expanded_expr $ - thing_inside - - mb_add_xexpr_wrap :: HsCtxt -> Bool -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc) - mb_add_xexpr_wrap hs_ctxt True thing_inside = mkExpandedTc hs_ctxt <$> setInGeneratedCode thing_inside - mb_add_xexpr_wrap _ False thing_inside = thing_inside + tcPolyLExprNC (L loc expr) res_ty tcPolyLExprNC (L loc expr) res_ty - = do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty + = setSrcSpanA loc $ + do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty ; e <- mb_add_xexpr_wrap (ExprCtxt expr) did_expand $ mb_add_ctxt ctxt (locA loc') expanded_expr $ case mb_ret_ty of @@ -313,30 +294,11 @@ tcMonoLExpr, tcMonoLExprNC tcMonoLExpr (L loc expr) res_ty = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] - do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty - ; e <- - mb_add_xexpr_wrap (ExprCtxt expr) did_expand $ mb_add_ctxt ctxt (locA loc') expanded_expr $ - case mb_ret_ty of - Nothing -> tcExpr expanded_expr res_ty - Just ds_res_ty -> do expr' <- tcExpr expanded_expr (Check ds_res_ty) - tcWrapResultMono expr expr' ds_res_ty res_ty - ; return (L loc' e) - } - where - mb_add_ctxt :: Maybe HsCtxt -> SrcSpan -> HsExpr GhcRn -> TcM a -> TcM a - mb_add_ctxt Nothing _ _ thing_inside - = thing_inside - mb_add_ctxt (Just ctxt) loc expanded_expr thing_inside - = addExpansionErrCtxt ctxt $ - addLExprCtxt loc expanded_expr $ - thing_inside - - mb_add_xexpr_wrap :: HsCtxt -> Bool -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc) - mb_add_xexpr_wrap hs_ctxt True thing_inside = mkExpandedTc hs_ctxt <$> setInGeneratedCode thing_inside - mb_add_xexpr_wrap _ False thing_inside = thing_inside + tcMonoLExprNC (L loc expr) res_ty tcMonoLExprNC (L loc expr) res_ty - = do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty + = setSrcSpanA loc $ + do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty ; e <- mb_add_xexpr_wrap (ExprCtxt expr) did_expand $ mb_add_ctxt ctxt (locA loc') expanded_expr $ case mb_ret_ty of ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -24,7 +24,7 @@ tcCheckMonoExpr, tcCheckMonoExprNC :: -> TcRhoType -> TcM (LHsExpr GhcTc) -tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) +tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc) tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b036900b32dfa9aab96a2da22ac7ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b036900b32dfa9aab96a2da22ac7ee… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ani/tc-expand
by Apoorv Ingle (＠ani) 14 Mar '26

14 Mar '26

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

1 0