- ghc-commits - Haskell.org

[Git][ghc/ghc][master] Evaluate backtraces for "error" exceptions at the moment they are thrown
by Marge Bot (＠marge-bot) 28 Jan '26

28 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 94dcd15e by Matthew Pickering at 2026-01-27T21:52:05-05:00 Evaluate backtraces for "error" exceptions at the moment they are thrown See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] which explain the implementation. This commit makes `error` and `throw` behave the same with regard to backtraces. Previously, exceptions raised by `error` would not contain useful IPE backtraces. I did try and implement `error` in terms of `throw` but it started to involve putting diverging functions into hs-boot files, which seemed to risky if the compiler wouldn't be able to see if applying a function would diverge. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383 Fixes #26751 - - - - - 9 changed files: - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/tests/stack-annotation/all.T - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - testsuite/tests/ghci.debugger/scripts/T8487.stdout - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break017.stdout - testsuite/tests/ghci.debugger/scripts/break025.stdout Changes: ===================================== libraries/base/changelog.md ===================================== @@ -24,6 +24,7 @@ * Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) * Add a new module `System.IO.OS` with operations for obtaining operating-system handles (file descriptors, Windows handles). ([CLC proposal #369](https://github.com/haskell/core-libraries-committee/issues/369)) + * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/ghc-internal/src/GHC/Internal/Err.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} {-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -25,6 +26,7 @@ module GHC.Internal.Err( absentErr, error, errorWithoutStackTrace, undefined ) where import GHC.Internal.Types (Char, RuntimeRep) import GHC.Internal.Stack.Types +import GHC.Internal.Magic import GHC.Internal.Prim import {-# SOURCE #-} GHC.Internal.Exception ( errorCallWithCallStackException @@ -33,7 +35,10 @@ import {-# SOURCE #-} GHC.Internal.Exception -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => [Char] -> a -error s = raise# (errorCallWithCallStackException s ?callStack) +error s = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException s ?callStack) + in raise# se -- Bleh, we should be using 'GHC.Internal.Stack.callStack' instead of -- '?callStack' here, but 'GHC.Internal.Stack.callStack' depends on -- 'GHC.Internal.Stack.popCallStack', which is partial and depends on @@ -73,7 +78,10 @@ undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). -- nor wanted (see #19886). We’d like to use withFrozenCallStack, but that -- is not available in this module yet, and making it so is hard. So let’s just -- use raise# directly. -undefined = raise# (errorCallWithCallStackException "Prelude.undefined" ?callStack) +undefined = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException "Prelude.undefined" ?callStack) + in raise# se -- | Used for compiler-generated error message; -- encoding saves bytes of string junk. ===================================== libraries/ghc-internal/tests/stack-annotation/all.T ===================================== @@ -8,3 +8,4 @@ test('ann_frame001', ann_frame_opts, compile_and_run, ['']) test('ann_frame002', ann_frame_opts, compile_and_run, ['']) test('ann_frame003', ann_frame_opts, compile_and_run, ['']) test('ann_frame004', ann_frame_opts, compile_and_run, ['']) +test('ann_frame005', ann_frame_opts, compile_and_run, ['']) ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs ===================================== @@ -0,0 +1,73 @@ +import Control.Concurrent.STM +import Control.Exception +import Control.Exception.Backtrace (BacktraceMechanism(IPEBacktrace), setBacktraceMechanismState) +import Control.Exception.Context (displayExceptionContext) +import Control.Monad +import Data.List (isInfixOf) +import TestUtils + +data SimpleBoom = SimpleBoom deriving (Show) + +instance Exception SimpleBoom + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + mapM_ (uncurry runCase) + [ ("throwIO SimpleBoom", throwIOAction) + , ("undefined", undefinedAction) + , ("error", errorAction) + , ("throwSTM", throwSTMAction) + ] + +runCase :: String -> IO () -> IO () +runCase label action = do + putStrLn ("=== " ++ label ++ " ===") + annotateCallStackIO $ + annotateStackStringIO ("catch site for " ++ label) $ + catch action (handler label) + +throwIOAction :: IO () +throwIOAction = + annotateStackStringIO "raising action" $ + annotateStackStringIO "throwIO SimpleBoom" $ + throwIO SimpleBoom + +undefinedAction :: IO () +undefinedAction = + annotateStackStringIO "raising undefined action" $ + void $ + evaluate $ + annotateStackString "undefined thunk" (undefined :: Int) + +errorAction :: IO () +errorAction = + annotateStackStringIO "raising error action" $ + void $ + evaluate $ + annotateStackString "error thunk" (error "error from annotateStackString" :: Int) + +throwSTMAction :: IO () +throwSTMAction = + annotateStackStringIO "raising throwSTM action" $ + atomically $ + annotateStackString "throwSTM SimpleBoom" $ + throwSTM SimpleBoom + +handler :: String -> SomeException -> IO () +handler label se = + annotateStackStringIO ("handler for " ++ label) $ + annotateStackStringIO ("forcing SomeException for " ++ label) $ do + message <- evaluate (displayException se) + putStrLn ("Caught exception: " ++ message) + let ctx = displayExceptionContext (someExceptionContext se) + ctxLines = lines ctx + putStrLn "Exception context:" + case ctxLines of + [] -> putStrLn "<empty>" + ls -> mapM_ (putStrLn . ("- " ++)) ls + let handlerTag = "handler for " ++ label + -- Check that the callstack is from the callsite, not the handling site + when (any (handlerTag `isInfixOf`) ctxLines) $ + error $ "handler annotation leaked into context for " ++ label + putStrLn "Handler annotation not present in context" ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout ===================================== @@ -0,0 +1,45 @@ +=== throwIO SimpleBoom === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- throwIO SimpleBoom +- raising action +- catch site for throwIO SimpleBoom +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- throwIO, called at ann_frame005.hs:34:7 in main:Main +Handler annotation not present in context +=== undefined === +Caught exception: Prelude.undefined +Exception context: +- IPE backtrace: +- undefined thunk +- raising undefined action +- catch site for undefined +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- undefined, called at ann_frame005.hs:41:48 in main:Main +Handler annotation not present in context +=== error === +Caught exception: error from annotateStackString +Exception context: +- IPE backtrace: +- error thunk +- raising error action +- catch site for error +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- error, called at ann_frame005.hs:48:44 in main:Main +Handler annotation not present in context +=== throwSTM === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- raising throwSTM action +- catch site for throwSTM +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- collectExceptionAnnotation, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:170:37 in ghc-internal:GHC.Internal.Exception +- toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/STM.hs:190:26 in ghc-internal:GHC.Internal.STM +- throwSTM, called at ann_frame005.hs:55:9 in main:Main +Handler annotation not present in context ===================================== testsuite/tests/ghci.debugger/scripts/T8487.stdout ===================================== @@ -1,4 +1,5 @@ Breakpoint 0 activated at T8487.hs:(5,8)-(7,53) Stopped in Main.f, T8487.hs:(5,8)-(7,53) _result :: IO String = _ -ma :: Either SomeException String = Left _ +ma :: Either SomeException String = Left + (SomeException (ErrorCall ...)) ===================================== testsuite/tests/ghci.debugger/scripts/break011.stdout ===================================== @@ -4,9 +4,10 @@ HasCallStack backtrace: error, called at <interactive>:2:1 in interactive:Ghci1 Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = SomeException (ErrorCall _) -1 : main (Test7.hs:2:18-28) -2 : main (Test7.hs:2:8-29) <end of history> @@ -26,7 +27,7 @@ _exception :: SomeException = SomeException (ErrorCall "foo") *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main Stopped in <exception thrown>, <unknown> _exception :: e = _ @@ -35,5 +36,5 @@ _exception :: e = _ *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main ===================================== testsuite/tests/ghci.debugger/scripts/break017.stdout ===================================== @@ -1,5 +1,6 @@ "Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Logged breakpoint at QSort.hs:6:32-34 _result :: Char -> Bool a :: Char ===================================== testsuite/tests/ghci.debugger/scripts/break025.stdout ===================================== @@ -1,3 +1,4 @@ Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94dcd15e54146abecf9b4f5e47d258c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94dcd15e54146abecf9b4f5e47d258c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] ci: update darwin boot ghc to 9.10.3
by Marge Bot (＠marge-bot) 28 Jan '26

28 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 50761451 by Cheng Shao at 2026-01-27T21:51:23-05:00 ci: update darwin boot ghc to 9.10.3 This patch updates darwin boot ghc to 9.10.3, along with other related updates, and pays off some technical debt here: - Update `nixpkgs` and use the `nixpkgs-25.05-darwin` channel. - Update the `niv` template. - Update LLVM to 21 and update `llvm-targets` to reflect LLVM 21 layout changes for arm64/x86_64 darwin targets. - Use `stdenvNoCC` to prevent nix packaged apple sdk from being used by boot ghc, and manually set `DEVELOPER_DIR`/`SDKROOT` to enforce the usage of system-wide command line sdk for macos. - When building nix derivation for boot ghc, run `configure` via the `arch` command so that `configure` and its subprocesses pick up the manually specified architecture. - Remove the previous horrible hack that obliterates `configure` to make autoconf test result in true. `configure` now properly does its job. - Remove the now obsolete configure args and post install settings file patching logic. - Use `scheme-small` for texlive to avoid build failures in certain unused texlive packages, especially on x86_64-darwin. - - - - - 3 changed files: - .gitlab/darwin/nix/sources.json - .gitlab/darwin/toolchain.nix - llvm-targets Changes: ===================================== .gitlab/darwin/nix/sources.json ===================================== @@ -1,26 +1,14 @@ { - "niv": { - "branch": "master", - "description": "Easy dependency management for Nix projects", - "homepage": "https://github.com/nmattia/niv", - "owner": "nmattia", - "repo": "niv", - "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070", - "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx", - "type": "tarball", - "url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad4…", - "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" - }, "nixpkgs": { - "branch": "nixos-unstable", + "branch": "nixpkgs-25.05-darwin", "description": "Nix Packages collection", "homepage": "", "owner": "nixos", "repo": "nixpkgs", - "rev": "2893f56de08021cffd9b6b6dfc70fd9ccd51eb60", - "sha256": "1anwxmjpm21msnnlrjdz19w31bxnbpn4kgf93sn3npihi7wf4a8h", + "rev": "3e3f3c7f9977dc123c23ee21e8085ed63daf8c37", + "sha256": "0jnmv6gpzhqb0jyhj7qi7vjfwbn4cqs5blm5xia7q5i0ma2bbkcd", "type": "tarball", - "url": "https://github.com/nixos/nixpkgs/archive/2893f56de08021cffd9b6b6dfc70fd9ccd…", + "url": "https://github.com/nixos/nixpkgs/archive/3e3f3c7f9977dc123c23ee21e8085ed63d…", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" } } ===================================== .gitlab/darwin/toolchain.nix ===================================== @@ -11,69 +11,67 @@ let hsPkgs = pkgs.haskellPackages; alex = hsPkgs.alex; happy = hsPkgs.happy; - targetTriple = pkgs.stdenv.targetPlatform.config; + targetTriple = pkgs.stdenvNoCC.targetPlatform.config; ghcBindists = let version = ghc.version; in { - aarch64-darwin = hostPkgs.fetchurl { + aarch64-darwin = hostPkgs.fetchzip { url = "https://downloads.haskell.org/ghc/${version}/ghc-${version}-aarch64-apple-d…"; - sha256 = "sha256-/6+DtdeossBJIMbjkJwL4h3eJ7rzgNCV+ifoQKOi6AQ="; + hash = "sha512-xUlt7zc/OT3a1SR0BxmFFgrabPkWUENATdw4NbQwEi5+nH5yPau+HSrGI5UUoKdO4gdpgZlPaxtI7eSk0fx1+g=="; }; - x86_64-darwin = hostPkgs.fetchurl { + x86_64-darwin = hostPkgs.fetchzip { url = "https://downloads.haskell.org/ghc/${version}/ghc-${version}-x86_64-apple-da…"; - sha256 = "sha256-jPIhiJMOENesUnDUJeIaPatgavc6ZVSTY5NFIAxlC+k="; + hash = "sha512-4/INeJwPPGbOj9MepwnIvIg2lvFkqS8w/3U/I8f6gCsoNlgwPr78iyY9vd6vfMONR1GxNQU3L/lxE07F3P0Qag=="; }; - }; - ghc = pkgs.stdenv.mkDerivation rec { - version = "9.10.1"; + ghc = pkgs.stdenvNoCC.mkDerivation rec { + version = "9.10.3"; name = "ghc"; - src = ghcBindists.${pkgs.stdenv.hostPlatform.system}; + src = ghcBindists.${pkgs.stdenvNoCC.hostPlatform.system}; + + dontUpdateAutotoolsGnuConfigScripts = true; + configureFlags = [ - "CC=/usr/bin/clang" - "CLANG=/usr/bin/clang" "AR=/usr/bin/ar" - "LLC=${llvm}/bin/llc" - "OPT=${llvm}/bin/opt" - "LLVMAS=${llvm_clang}/bin/clang" - "CONF_CC_OPTS_STAGE2=--target=${targetTriple}" - "CONF_CXX_OPTS_STAGE2=--target=${targetTriple}" - "CONF_GCC_LINKER_OPTS_STAGE2=--target=${targetTriple}" + "CC=/usr/bin/clang" + "CXX=/usr/bin/clang++" + "INSTALL=/usr/bin/install" + "INSTALL_NAME_TOOL=/usr/bin/install_name_tool" + "MergeObjsCmd=/usr/bin/ld" + "NM=/usr/bin/nm" + "OTOOL=/usr/bin/otool" + "RANLIB=/usr/bin/ranlib" ]; - buildPhase = "true"; - - # This is a horrible hack because the configure script invokes /usr/bin/clang - # without a `--target` flag. Then depending on whether the `nix` binary itself is - # a native x86 or arm64 binary means that /usr/bin/clang thinks it needs to run in - # x86 or arm64 mode. - - # The correct answer for the check in question is the first one we try, so by replacing - # the condition to true; we select the right C++ standard library still. - preConfigure = '' - sed "s/\"\$CC\" -o actest actest.o \''${1} 2>\/dev\/null/true/i" configure > configure.new - mv configure.new configure - chmod +x configure - cat configure + # Use the arch command to explicitly specify architecture, so that + # configure and its subprocesses would pick up the architecture we + # choose via the system argument. + preConfigure = pkgs.lib.optionalString (system == "aarch64-darwin") '' + substituteInPlace configure \ + --replace-fail "#! /bin/sh" "#!/usr/bin/env -S /usr/bin/arch -arm64 /bin/sh" + '' + pkgs.lib.optionalString (system == "x86_64-darwin") '' + substituteInPlace configure \ + --replace-fail "#! /bin/sh" "#!/usr/bin/env -S /usr/bin/arch -x86_64 /bin/sh" + '' + '' + unset DEVELOPER_DIR SDKROOT + export DEVELOPER_DIR="$(/usr/bin/xcode-select --print-path)" + export SDKROOT="$(/usr/bin/xcrun --sdk macosx --show-sdk-path)" ''; + dontPatchShebangsInConfigure = true; + # N.B. Work around #20253. nativeBuildInputs = [ pkgs.gnused ]; - postInstallPhase = '' - settings="$out/lib/ghc-${version}/settings" - sed -i -e "s%\"llc\"%\"${llvm}/bin/llc\"%" $settings - sed -i -e "s%\"opt\"%\"${llvm}/bin/opt\"%" $settings - sed -i -e "s%\"clang\"%\"/usr/bin/clang\"%" $settings - sed -i -e 's%("C compiler command", "")%("C compiler command", "/usr/bin/clang")%' $settings - sed -i -e 's%("C compiler flags", "")%("C compiler flags", "--target=${targetTriple}")%' $settings - sed -i -e 's%("C++ compiler flags", "")%("C++ compiler flags", "--target=${targetTriple}")%' $settings - sed -i -e 's%("C compiler link flags", "")%("C compiler link flags", "--target=${targetTriple}")%' $settings - ''; + + dontBuild = true; + + enableParallelInstalling = true; + + dontFixup = true; # Sanity check: verify that we can compile hello world. doInstallCheck = true; installCheckPhase = '' - unset DYLD_LIBRARY_PATH $out/bin/ghc --info cd $TMP mkdir test-ghc; cd test-ghc @@ -91,13 +89,13 @@ let ourtexlive = with pkgs; texlive.combine { inherit (texlive) - scheme-medium collection-xetex fncychap titlesec tabulary varwidth + scheme-small collection-xetex fncychap tex-gyre titlesec tabulary varwidth framed capt-of wrapfig needspace dejavu-otf helvetic upquote; }; fonts = with pkgs; makeFontsConf { fontDirectories = [ dejavu_fonts ]; }; - llvm = pkgs.llvm_15; - llvm_clang = pkgs.llvmPackages_15.clang-unwrapped; + llvm = pkgs.llvm_21; + llvm_clang = pkgs.llvmPackages_21.clang-unwrapped; in pkgs.writeTextFile { name = "toolchain"; ===================================== llvm-targets ===================================== @@ -44,8 +44,8 @@ ,("riscv64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax")) ,("loongarch64-unknown-linux-gnu", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+f +d")) ,("loongarch64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+f +d")) -,("x86_64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "penryn", "")) -,("arm64-apple-darwin", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+v8.3a +fp-armv8 +neon +crc +crypto +fullfp16 +ras +lse +rdm +rcpc +zcm +zcz +sha2 +aes")) +,("x86_64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-i128:128-f80:128-n8:16:32:64-S128", "core2", "")) +,("arm64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-i128:128-n32:64-S128-Fn32", "apple-m1", "+v8.4a +aes +altnzcv +ccdp +ccpp +complxnum +crc +dotprod +flagm +fp-armv8 +fp16fml +fptoint +fullfp16 +jsconv +lse +neon +pauth +perfmon +predres +ras +rcpc +rdm +sb +sha2 +sha3 +specrestrict +ssbs")) ,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "apple-a7", "+fp-armv8 +neon +crypto +zcm +zcz +sha2 +aes")) ,("x86_64-apple-ios", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "core2", "")) ,("amd64-portbld-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5076145148541cc4e38cace52745e90… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5076145148541cc4e38cace52745e90… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/linker_fix] 35 commits: base: don't expose GHC.Num.{BigNat, Integer, Natural}
by Andreas Klebinger (＠AndreasK) 28 Jan '26

28 Jan '26

Andreas Klebinger pushed to branch wip/andreask/linker_fix at Glasgow Haskell Compiler / GHC Commits: 30f442a9 by Teo Camarasu at 2026-01-20T13:57:26-05:00 base: don't expose GHC.Num.{BigNat, Integer, Natural} We no longer expose GHC.Num.{BigNat, Integer, Natural} from base instead users should get these modules from ghc-bignum. We make this change to insulate end users from changes to GHC's implementation of big numbers. Implements CLC proposal 359: https://github.com/haskell/core-libraries-committee/issues/359 - - - - - 75a9053d by Teo Camarasu at 2026-01-20T13:58:07-05:00 base: deprecate GHC internals in GHC.Num Implements CLC proposal: https://github.com/haskell/core-libraries-committee/issues/360 - - - - - 9534b032 by Andreas Klebinger at 2026-01-20T13:58:50-05:00 ghc-experimental: Update Changelog I tried to reconstruct a high level overview of the changes and when they were made since we introduced it. Fixes #26506 Co-authored-by: Teo Camarasu <teofilcamarasu(a)gmail.com> - - - - - 346f2f5a by Cheng Shao at 2026-01-20T13:59:30-05:00 hadrian: remove RTS options in ghc-in-ghci flavour This patch removes the RTS options passed to ghc in ghc-in-ghci flavour, to workaround command line argument handling issue in hls/hie-boot that results in `-O64M` instead of `+RTS -O64M -RTS` being passed to ghc. It's not a hadrian bug per se, since ghc's own ghc-in-ghci multi repl works fine, but we should still make sure HLS works. Closes #26801. - - - - - 759fd15a by Andreas Klebinger at 2026-01-21T16:05:28-05:00 Don't build GHC with -Wcompat Without bumping the boot compiler the warnings it produces are often not actionable leading to pointless noise. Fixes #26800 - - - - - 3172db94 by Torsten Schmits at 2026-01-21T16:06:11-05:00 Use the correct field of ModOrigin when formatting error message listing hidden reexports - - - - - 485c12b2 by Cheng Shao at 2026-01-21T16:06:54-05:00 Revert "hadrian: handle findExecutable "" gracefully" This reverts commit 1e5752f64a522c4025365856d92f78073a7b3bba. The underlying issue has been fixed in https://github.com/haskell/directory/commit/75828696e7145adc09179111a0d631b… and present since 1.3.9.0, and hadrian directory lower bound is 1.3.9.0, so we can revert our own in house hack now. - - - - - 5efb58dc by Cheng Shao at 2026-01-21T16:07:36-05:00 rts: fix typo in TICK_ALLOC_RTS This patch fixes a typo in the `TICK_ALLOC_RTS` macro, the original `bytes` argument was silently dropped. The Cmm code has its own version of `TICK_ALLOC_RTS` not affected by this typo, it affected the C RTS, and went unnoticed because the variable `n` happened to also be available at its call site. But the number was incorrect. Also fixes its call site since `WDS()` is not available in C. - - - - - c406ea69 by Cheng Shao at 2026-01-21T16:07:36-05:00 rts: remove broken & unused ALLOC_P_TICKY This patch removes the `ALLOC_P_TICKY` macro from the rts, it's unused, and its expanded code is already broken. - - - - - 34a27e20 by Simon Peyton Jones at 2026-01-21T16:08:17-05:00 Make the implicit-parameter class have representational role This MR addresses #26737, by making the built-in class IP have a representational role for its second parameter. See Note [IP: implicit parameter class] in ghc-internal:GHC.Internal.Classes.IP In fact, IP is (unfortunately, currently) exposed by base:GHC.Base, so we ran a quick CLC proposal to agree the change: https://github.com/haskell/core-libraries-committee/issues/385 Some (small) compilations get faster because they only need to load (small) interface file GHC.Internal.Classes.IP.hi, rather than (large) GHC.Internal.Classes.hi. Metric Decrease: T10421 T12150 T12425 T24582 T5837 T5030 - - - - - ca79475f by Cheng Shao at 2026-01-21T16:09:00-05:00 testsuite: avoid re.sub in favor of simple string replacements This patch refactors the testsuite driver and avoids the usage of re.sub in favor of simple string replacements when possible. The changes are not comprehensive, and there are still a lot of re.sub usages lingering around the tree, but this already addresses a major performance bottleneck in the testsuite driver that might has to do with quadratic or worse slowdown in cpython's regular expression engine when handling certain regex patterns with large strings. Especially on i386, and i386 jobs are the bottlenecks of all full-ci validate pipelines! Here are the elapsed times of testing x86_64/i386 with -j48 before this patch: x86_64: `Build completed in 6m06s` i386: `Build completed in 1h36m` And with this patch: x86_64: `Build completed in 4m55s` i386: `Build completed in 4m23s` Fixes #26786. Co-authored-by: Codex <codex(a)openai.com> - - - - - 88c93796 by Zubin Duggal at 2026-01-21T16:09:42-05:00 ghc-toolchain: Also configure windres on non-windows platforms. It may be needed for cross compilation. Fixes #24588 - - - - - 9788c0ec by Cheng Shao at 2026-01-21T16:10:24-05:00 ghci: print external interpreter trace messages to stderr instead of stdout This patch makes ghci print external interpreter trace messages to stderr instead of stdout, which is a much saner choice for diagnostic information. Closes #26807. - - - - - 0491f08a by Sylvain Henry at 2026-01-22T03:44:26-05:00 GC: don't use CAS without PARALLEL_GC on If we're not using the parallel GC, there is no reason to do a costly CAS. This was flagged as taking time in a perf profile. - - - - - 211a8f56 by Sylvain Henry at 2026-01-22T03:44:26-05:00 GC: suffix parallel GC with "par" instead of "thr" Avoid some potential confusion (see discussion in !15351). - - - - - 77a23cbd by fendor at 2026-01-22T03:45:08-05:00 Remove blanket ignore that covers libraries/ - - - - - 18bf7f5c by Léana Jiang at 2026-01-22T08:58:45-05:00 doc: update Flavour type in hadrian user-settings - - - - - 3d5a1365 by Cheng Shao at 2026-01-22T08:59:28-05:00 hadrian: add missing notCross predicate for stage0 -O0 There are a few hard-coded hadrian args that pass -O0 when compiling some heavy modules in stage0, which only makes sense when not cross-compiling and when cross-compiling we need properly optimized stage0 packages. So this patch adds the missing `notCross` predicate in those places. - - - - - ee937134 by Matthew Pickering at 2026-01-22T09:00:10-05:00 Fix ghc-experimental GHC.Exception.Backtrace.Experimental module This module wasn't added to the cabal file so it was never compiled or included in the library. - - - - - 1b490f5a by Zubin Duggal at 2026-01-22T09:00:53-05:00 hadrian: Add ghc-{experimental,internal}.cabal to the list of dependencies of the doc target We need these files to detect the version of these libraries Fixes #26738 - - - - - cdb74049 by Cheng Shao at 2026-01-22T14:52:36-05:00 rts: avoid Cmm loop to initialize Array#/SmallArray# Previously, `newArray#`/`newSmallArray#` called an RTS C function to allocate the `Array#`/`SmallArray#`, then used a Cmm loop to initialize the elements. Cmm doesn't have native for-loop so the code is a bit awkward, and it's less efficient than a C loop, since the C compiler can effectively vectorize the loop with optimizations. So this patch moves the loop that initializes the elements to the C side. `allocateMutArrPtrs`/`allocateSmallMutArrPtrs` now takes a new `init` argument and initializes the elements if `init` is non-NULL. - - - - - 4c784f00 by Cheng Shao at 2026-01-22T14:53:19-05:00 Fix testsuite run for +ipe flavour transformer This patch makes the +ipe flavour transformer pass the entire testsuite: - An RTS debug option `-DI` is added, the IPE trace information is now only printed with `-DI`. The test cases that do require IPE trace are now run with `-DI`. - The testsuite config option `ghc_with_ipe` is added, enabled when running the testsuite with `+ipe`, which skips a few tests that are sensitive to eventlog output, allocation patterns etc that can fail under `+ipe`. This is the first step towards #26799. Co-authored-by: Codex <codex(a)openai.com> - - - - - be8e5236 by Ben Gamari at 2026-01-23T03:28:45-05:00 hadrian: Bump QuickCheck upper bound This patch bumps QuickCheck upper bound to 2.18. selftest rule manually tested to work with current latest QuickCheck-2.17.1.0. - - - - - 5aa328fb by Zubin Duggal at 2026-01-23T03:29:30-05:00 Add genindex to index.rst. This adds a link to the index in the navigation bar. Fixes #26437 - - - - - 917ab8ff by Oleg Grenrus at 2026-01-23T10:52:55-05:00 Export labelThread from Control.Concurrent - - - - - 3f5e8d80 by Cheng Shao at 2026-01-23T10:53:37-05:00 ci: only push perf notes on master/release branches This patch fixes push_perf_notes logic in ci.sh to only push perf notes on master/release branches. We used to unconditionally push perf notes even in MRs, but the perf numbers in the wip branches wouldn't be used as baseline anyway, plus this is causing a space leak in the ghc-performance-notes repo. See #25317 for the perf notes repo size problem. Co-authored-by: Codex <codex(a)openai.com> - - - - - 414b9593 by Cheng Shao at 2026-01-24T07:11:51-05:00 ci: remove duplicate keys in .gitlab-ci.yml This patch removes accidentally duplicate keys in `.gitlab-ci.yml`. The YAML spec doesn't allow duplicate keys in the first place, and according to GitLab docs (https://docs.gitlab.com/ci/yaml/yaml_optimization/#anchors) the latest key overrides the earlier entries. - - - - - e5cb5491 by Cheng Shao at 2026-01-24T07:12:34-05:00 hadrian: drop obsolete configure/make builder logic for libffi This patch drops obsolete hadrian logic around `Configure libffiPath`/`Make libffiPath` builders, they are no longer needed after libffi-clib has landed. Closes #26815. - - - - - 2d160222 by Simon Hengel at 2026-01-24T07:13:17-05:00 Fix typo in roles.rst - - - - - 56db94f7 by Peter Trommler at 2026-01-26T11:26:18+01:00 PPC NCG: Generate clear right insn at arch width The clear right immediate (clrrxi) is only available in word and doubleword width. Generate clrrxi instructions at architecture width for all MachOp widths. Fixes #24145 - - - - - 5957a8ad by Wolfgang Jeltsch at 2026-01-27T06:11:40-05:00 Add operations for obtaining operating-system handles This contribution implements CLC proposal #369. It adds operations for obtaining POSIX file descriptors and Windows handles that underlie Haskell handles. Those operating system handles can also be obtained without such additional operations, but this is more involved and, more importantly, requires using internals. - - - - - 86a0510c by Greg Steuck at 2026-01-27T06:12:34-05:00 Move flags to precede patterns for grep and read files directly This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools. There's no reason to use cat and pipe where direct file argument works. - - - - - 6203cc28 by Andreas Klebinger at 2026-01-27T20:14:03+01:00 rts: LoadArchive/LoadObj - refactor object verification. Fixes #26231. We now consistently call `verifyAndInitOc` to check for valid object code. Allowing us to replace the somewhat adhoc magic number checking in loadArchive with the platform specific verification logic. On windows this adds loadArchive support for AArch64/32bit COFF bigobj files. - - - - - a1ea60ad by Andreas Klebinger at 2026-01-27T20:14:03+01:00 Remove now redundant thin archive special case. - - - - - 4e457612 by Andreas Klebinger at 2026-01-27T20:14:04+01:00 RTS Linker: Refactor import lib detection on windows. - - - - - 106 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - compiler/GHC/Builtin/Names.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in - docs/users_guide/9.16.1-notes.rst - docs/users_guide/exts/roles.rst - docs/users_guide/index.rst - docs/users_guide/runtime_control.rst - hadrian/doc/user-settings.md - hadrian/hadrian.cabal - hadrian/src/Context.hs - hadrian/src/Flavour.hs - hadrian/src/Hadrian/Utilities.hs - hadrian/src/Rules/Docspec.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Lint.hs - hadrian/src/Settings/Builders/Configure.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Builders/Make.hs - hadrian/src/Settings/Builders/RunTest.hs - hadrian/src/Settings/Flavours/GhcInGhci.hs - hadrian/src/Settings/Packages.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/base/src/Control/Concurrent.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/GHC/Num.hs - − libraries/base/src/GHC/Num/BigNat.hs - − libraries/base/src/GHC/Num/Integer.hs - − libraries/base/src/GHC/Num/Natural.hs - libraries/base/src/System/CPUTime/Utils.hs - + libraries/base/src/System/IO/OS.hs - libraries/base/src/System/Timeout.hs - libraries/base/tests/IO/all.T - + libraries/base/tests/IO/osHandles001FileDescriptors.hs - + libraries/base/tests/IO/osHandles001FileDescriptors.stdout - + libraries/base/tests/IO/osHandles001WindowsHandles.hs - + libraries/base/tests/IO/osHandles001WindowsHandles.stdout - + libraries/base/tests/IO/osHandles002FileDescriptors.hs - + libraries/base/tests/IO/osHandles002FileDescriptors.stderr - + libraries/base/tests/IO/osHandles002FileDescriptors.stdin - + libraries/base/tests/IO/osHandles002FileDescriptors.stdout - + libraries/base/tests/IO/osHandles002WindowsHandles.hs - + libraries/base/tests/IO/osHandles002WindowsHandles.stderr - + libraries/base/tests/IO/osHandles002WindowsHandles.stdin - + libraries/base/tests/IO/osHandles002WindowsHandles.stdout - libraries/base/tests/perf/Makefile - libraries/ghc-bignum/ghc-bignum.cabal - libraries/ghc-compact/tests/all.T - libraries/ghc-experimental/CHANGELOG.md - libraries/ghc-experimental/ghc-experimental.cabal.in - libraries/ghc-experimental/src/GHC/Exception/Backtrace/Experimental.hs - libraries/ghc-experimental/src/GHC/TypeNats/Experimental.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Classes.hs - + libraries/ghc-internal/src/GHC/Internal/Classes/IP.hs - + libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/tests/backtraces/all.T - libraries/ghci/GHCi/Server.hs - rts/AllocArray.c - rts/AllocArray.h - rts/ClosureTable.c - rts/Heap.c - rts/Linker.c - rts/LinkerInternals.h - rts/PrimOps.cmm - rts/RtsFlags.c - rts/Threads.c - rts/Trace.c - rts/Weak.c - rts/include/Cmm.h - rts/include/rts/Flags.h - rts/include/stg/Ticky.h - rts/linker/LoadArchive.c - rts/linker/MachO.c - rts/linker/MachO.h - rts/linker/PEi386.c - rts/rts.cabal - rts/sm/Evac.c - rts/sm/Evac_thr.c → rts/sm/Evac_par.c - rts/sm/Scav_thr.c → rts/sm/Scav_par.c - rts/sm/Storage.c - testsuite/driver/runtests.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/driver/testutil.py - testsuite/tests/driver/T16318/Makefile - testsuite/tests/driver/T18125/Makefile - 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/base-exports.stdout-ws-32 - 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/rts/Makefile - testsuite/tests/rts/all.T - testsuite/tests/rts/ipe/all.T - testsuite/tests/th/TH_implicitParams.stdout - + testsuite/tests/typecheck/should_compile/T26737.hs - testsuite/tests/typecheck/should_compile/all.T - utils/ghc-toolchain/exe/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bcf76dcc3577280023a7d57b80b8cc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bcf76dcc3577280023a7d57b80b8cc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26832] 3 commits: ghc-internal: avoid depending on GHC.Internal.Exts
by Teo Camarasu (＠teo) 28 Jan '26

28 Jan '26

Teo Camarasu pushed to branch wip/T26832 at Glasgow Haskell Compiler / GHC Commits: 1c10c8f2 by Teo Camarasu at 2026-01-27T15:46:24+00:00 ghc-internal: avoid depending on GHC.Internal.Exts This module is mostly just re-exports. It made sense as a user-facing module, but there's no good reason ghc-internal modules should depend on it and doing so linearises the module graph - - - - - c1754218 by Teo Camarasu at 2026-01-27T15:46:24+00:00 ghc-internal: move considerAccessible to GHC.Internal.Magic Previously it lived in GHC.Internal.Exts, but it really deserves to live along with the other magic function, which are already re-exported from .Exts - - - - - 99b48b81 by Teo Camarasu at 2026-01-27T15:46:25+00:00 ghc-internal: move maxTupleSize to GHC.Internal.Tuple This previously lived in GHC.Internal.Exts but a comment already said it should be moved to .Tuple - - - - - 14 changed files: - compiler/GHC/Builtin/Names.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.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/JS/Prim/Internal/Build.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs - libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -1063,7 +1063,7 @@ alternativeClassKey = mkPreludeMiscIdUnique 754 -- Functions for GHC extensions considerAccessibleName :: Name -considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey +considerAccessibleName = varQual gHC_MAGIC (fsLit "considerAccessible") considerAccessibleIdKey -- Random GHC.Internal.Base functions fromStringName, otherwiseIdName, foldrName, buildName, augmentName, ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -321,10 +321,7 @@ import GHC.Internal.Data.Data import GHC.Internal.Data.Ord import qualified GHC.Internal.Debug.Trace import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) -- just for re-export - --- XXX This should really be in Data.Tuple, where the definitions are -maxTupleSize :: Int -maxTupleSize = 64 +import GHC.Internal.Tuple (maxTupleSize) -- | 'the' ensures that all the elements of the list are identical -- and then returns that unique element @@ -444,27 +441,3 @@ resizeSmallMutableArray# arr0 szNew a s0 = (# s2, arr1 #) -> case copySmallMutableArray# arr0 0# arr1 0# szOld s2 of s3 -> (# s3, arr1 #) else (# s1, arr0 #) - --- | Semantically, @considerAccessible = True@. But it has special meaning --- to the pattern-match checker, which will never flag the clause in which --- 'considerAccessible' occurs as a guard as redundant or inaccessible. --- Example: --- --- > case (x, x) of --- > (True, True) -> 1 --- > (False, False) -> 2 --- > (True, False) -> 3 -- Warning: redundant --- --- The pattern-match checker will warn here that the third clause is redundant. --- It will stop doing so if the clause is adorned with 'considerAccessible': --- --- > case (x, x) of --- > (True, True) -> 1 --- > (False, False) -> 2 --- > (True, False) | considerAccessible -> 3 -- No warning --- --- Put 'considerAccessible' as the last statement of the guard to avoid get --- confusing results from the pattern-match checker, which takes \"consider --- accessible\" by word. -considerAccessible :: Bool -considerAccessible = True ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs ===================================== @@ -75,9 +75,10 @@ import GHC.Internal.Int import GHC.Internal.Num import GHC.Internal.Real import GHC.Internal.Word -import GHC.Internal.Exts import GHC.Internal.Generics import GHC.Internal.Numeric +import GHC.Internal.Ptr +import GHC.Internal.Unsafe.Coerce import GHC.Internal.Stack (HasCallStack) ------------------------------------------------------------------------ ===================================== libraries/ghc-internal/src/GHC/Internal/JS/Foreign/Callback.hs ===================================== @@ -21,8 +21,6 @@ module GHC.Internal.JS.Foreign.Callback import GHC.Internal.JS.Prim -import qualified GHC.Internal.Exts as Exts - import GHC.Internal.Unsafe.Coerce import GHC.Internal.Base @@ -131,18 +129,18 @@ asyncCallback3 x = js_asyncCallbackApply 3 (unsafeCoerce x) -- ---------------------------------------------------------------------------- foreign import javascript unsafe "(($1, $2) => { return h$makeCallback(h$runSync, [$1], $2); })" - js_syncCallback :: Bool -> Exts.Any -> IO (Callback (IO b)) + js_syncCallback :: Bool -> Any -> IO (Callback (IO b)) foreign import javascript unsafe "(($1) => { return h$makeCallback(h$run, [], $1); })" - js_asyncCallback :: Exts.Any -> IO (Callback (IO b)) + js_asyncCallback :: Any -> IO (Callback (IO b)) foreign import javascript unsafe "(($1) => { return h$makeCallback(h$runSyncReturn, [false], $1); })" - js_syncCallbackReturn :: Exts.Any -> IO (Callback (IO JSVal)) + js_syncCallbackReturn :: Any -> IO (Callback (IO JSVal)) foreign import javascript unsafe "(($1, $2, $3) => { return h$makeCallbackApply($2, h$runSync, [$1], $3); })" - js_syncCallbackApply :: Bool -> Int -> Exts.Any -> IO (Callback b) + js_syncCallbackApply :: Bool -> Int -> Any -> IO (Callback b) foreign import javascript unsafe "(($1, $2) => { return h$makeCallbackApply($1, h$run, [], $2); })" - js_asyncCallbackApply :: Int -> Exts.Any -> IO (Callback b) + js_asyncCallbackApply :: Int -> Any -> IO (Callback b) foreign import javascript unsafe "(($1, $2) => { return h$makeCallbackApply($1, h$runSyncReturn, [false], $2); })" - js_syncCallbackApplyReturn :: Int -> Exts.Any -> IO (Callback b) + js_syncCallbackApplyReturn :: Int -> Any -> IO (Callback b) foreign import javascript unsafe "h$release" js_release :: Callback a -> IO () ===================================== libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs ===================================== @@ -42,8 +42,8 @@ module GHC.Internal.JS.Prim ( JSVal(..), JSVal# import GHC.Internal.Unsafe.Coerce (unsafeCoerce) import GHC.Internal.Prim +import GHC.Internal.Types import qualified GHC.Internal.Exception as Ex -import qualified GHC.Internal.Exts as Exts import qualified GHC.Internal.CString as GHC import GHC.Internal.IO import GHC.Internal.Data.Bool @@ -78,15 +78,15 @@ instance Show JSException where #if defined(javascript_HOST_ARCH) {-# NOINLINE toIO #-} -toIO :: Exts.Any -> IO Exts.Any +toIO :: Any -> IO Any toIO x = pure x {-# NOINLINE resolve #-} -resolve :: JSVal# -> JSVal# -> Exts.Any -> IO () +resolve :: JSVal# -> JSVal# -> Any -> IO () resolve accept reject x = resolveIO accept reject (pure x) {-# NOINLINE resolveIO #-} -- used by the rts -resolveIO :: JSVal# -> JSVal# -> IO Exts.Any -> IO () +resolveIO :: JSVal# -> JSVal# -> IO Any -> IO () resolveIO accept reject x = (x >>= evaluate >>= js_callback_any accept) `catch` (\(e::Ex.SomeException) -> do @@ -260,16 +260,16 @@ seqList xs = go xs `seq` xs go [] = () foreign import javascript unsafe "h$toHsString" - js_fromJSString :: JSVal -> Exts.Any + js_fromJSString :: JSVal -> Any foreign import javascript unsafe "h$fromHsString" - js_toJSString :: Exts.Any -> JSVal + js_toJSString :: Any -> JSVal foreign import javascript unsafe "h$toHsListJSVal" - js_fromJSArray :: JSVal -> IO Exts.Any + js_fromJSArray :: JSVal -> IO Any foreign import javascript unsafe "h$fromHsListJSVal" - js_toJSArray :: Exts.Any -> IO JSVal + js_toJSArray :: Any -> IO JSVal foreign import javascript unsafe "(($1) => { return ($1 === null); })" js_isNull :: JSVal -> Bool @@ -287,10 +287,10 @@ foreign import javascript unsafe "(() => { return null; })" js_null :: JSVal foreign import javascript unsafe "(($1,$2) => { return $1[h$fromHsString($2)]; })" - js_getProp :: JSVal -> Exts.Any -> IO JSVal + js_getProp :: JSVal -> Any -> IO JSVal foreign import javascript unsafe "(($1,$2) => { return $1[h$fromHsString($2)]; })" - js_unsafeGetProp :: JSVal -> Exts.Any -> JSVal + js_unsafeGetProp :: JSVal -> Any -> JSVal foreign import javascript unsafe "(($1,$2) => { return $1[$2]; })" js_getProp' :: JSVal -> JSVal -> IO JSVal @@ -311,7 +311,7 @@ foreign import javascript unsafe "(($1_1, $1_2) => { return h$decodeUtf8z($1_1,$ js_unsafeUnpackJSStringUtf8## :: Addr# -> JSVal# foreign import javascript unsafe "(($1, $2) => { return $1($2); })" - js_callback_any :: JSVal# -> Exts.Any -> IO () + js_callback_any :: JSVal# -> Any -> IO () foreign import javascript unsafe "(($1, $2) => { return $1($2); })" js_callback_jsval :: JSVal# -> JSVal -> IO () ===================================== libraries/ghc-internal/src/GHC/Internal/JS/Prim/Internal/Build.hs ===================================== @@ -145,7 +145,6 @@ module GHC.Internal.JS.Prim.Internal.Build ) where import GHC.Internal.JS.Prim -import GHC.Internal.Exts import GHC.Internal.IO import GHC.Internal.Unsafe.Coerce import GHC.Internal.Base ===================================== libraries/ghc-internal/src/GHC/Internal/Magic.hs ===================================== @@ -24,7 +24,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..), considerAccessible ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -34,7 +34,7 @@ module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(. -- because TYPE is not exported by the source Haskell module generated by -- genprimops which Haddock will typecheck (#15935). import GHC.Internal.Prim (State#, realWorld#, RealWorld, Int#) -import GHC.Internal.Types (RuntimeRep(BoxedRep), TYPE, Levity, Constraint) +import GHC.Internal.Types (RuntimeRep(BoxedRep), TYPE, Levity, Constraint, Bool(True)) -- | The call @inline f@ arranges that @f@ is inlined, regardless of -- its size. More precisely, the call @inline f@ rewrites to the @@ -137,3 +137,27 @@ type DataToTag :: forall {lev :: Levity}. TYPE (BoxedRep lev) -> Constraint -- So it does not get its own Unsafe module, unlike WithDict. class DataToTag a where dataToTag# :: a -> Int# + +-- | Semantically, @considerAccessible = True@. But it has special meaning +-- to the pattern-match checker, which will never flag the clause in which +-- 'considerAccessible' occurs as a guard as redundant or inaccessible. +-- Example: +-- +-- > case (x, x) of +-- > (True, True) -> 1 +-- > (False, False) -> 2 +-- > (True, False) -> 3 -- Warning: redundant +-- +-- The pattern-match checker will warn here that the third clause is redundant. +-- It will stop doing so if the clause is adorned with 'considerAccessible': +-- +-- > case (x, x) of +-- > (True, True) -> 1 +-- > (False, False) -> 2 +-- > (True, False) | considerAccessible -> 3 -- No warning +-- +-- Put 'considerAccessible' as the last statement of the guard to avoid get +-- confusing results from the pattern-match checker, which takes \"consider +-- accessible\" by word. +considerAccessible :: Bool +considerAccessible = True ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -40,8 +40,8 @@ import GHC.Internal.Data.List import GHC.Internal.Data.Tuple import GHC.Internal.Foreign.Ptr import GHC.Internal.Foreign.Storable -import GHC.Internal.Exts import GHC.Internal.Unsafe.Coerce +import GHC.Internal.Ptr import GHC.Internal.ClosureTypes import GHC.Internal.Heap.Closures ===================================== libraries/ghc-internal/src/GHC/Internal/Tuple.hs ===================================== @@ -27,10 +27,11 @@ module GHC.Internal.Tuple ( Tuple40(..), Tuple41(..), Tuple42(..), Tuple43(..), Tuple44(..), Tuple45(..), Tuple46(..), Tuple47(..), Tuple48(..), Tuple49(..), Tuple50(..), Tuple51(..), Tuple52(..), Tuple53(..), Tuple54(..), Tuple55(..), Tuple56(..), Tuple57(..), Tuple58(..), Tuple59(..), Tuple60(..), Tuple61(..), Tuple62(..), Tuple63(..), Tuple64(..), + maxTupleSize, ) where -- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base -import GHC.Internal.Types () +import GHC.Internal.Types (Int) default () -- Double and Integer aren't available yet @@ -598,3 +599,6 @@ data Tuple64 a b c d e f g h i j k l m n o p q r s t u v w x y z a1 b1 c1 d1 e1 r1 s1 t1 u1 v1 w1 x1 y1 z1 a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) + +maxTupleSize :: Int +maxTupleSize = 64 ===================================== libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs ===================================== @@ -32,7 +32,6 @@ module GHC.Internal.Wasm.Prim.Exports ( import GHC.Internal.Base import GHC.Internal.Exception.Type -import GHC.Internal.Exts import GHC.Internal.IO import GHC.Internal.IORef import GHC.Internal.Int @@ -40,6 +39,7 @@ import GHC.Internal.Stable import GHC.Internal.TopHandler (flushStdHandles) import GHC.Internal.Wasm.Prim.Types import GHC.Internal.Word +import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) mkJSCallback :: (StablePtr a -> IO JSVal) -> a -> IO JSVal mkJSCallback adjustor f = do ===================================== libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs ===================================== @@ -30,10 +30,10 @@ module GHC.Internal.Wasm.Prim.Imports ( import GHC.Internal.Base import GHC.Internal.Exception -import GHC.Internal.Exts import GHC.Internal.IO.Unsafe import GHC.Internal.Stable import GHC.Internal.Wasm.Prim.Types +import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) {-# OPAQUE raiseJSException #-} raiseJSException :: JSVal -> a ===================================== libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs ===================================== @@ -20,9 +20,9 @@ module GHC.Internal.Wasm.Prim.Types ( import GHC.Internal.Base import GHC.Internal.Exception.Type -import GHC.Internal.Exts import GHC.Internal.Foreign.C.String.Encoding import GHC.Internal.ForeignPtr +import GHC.Internal.Ptr import GHC.Internal.IO import GHC.Internal.IO.Encoding import GHC.Internal.Num ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -4453,6 +4453,7 @@ module Data.Tuple.Experimental where type Unit# :: GHC.Internal.Types.ZeroBitType data Unit# = ... getSolo :: forall a. Solo a -> a + maxTupleSize :: GHC.Internal.Types.Int module GHC.Exception.Backtrace.Experimental where -- Safety: None @@ -11044,6 +11045,7 @@ module Prelude.Experimental where type Unit# :: GHC.Internal.Types.ZeroBitType data Unit# = ... getSolo :: forall a. Solo a -> a + maxTupleSize :: GHC.Internal.Types.Int module System.Mem.Experimental where -- Safety: None ===================================== testsuite/tests/interface-stability/ghc-prim-exports.stdout ===================================== @@ -1232,6 +1232,7 @@ module GHC.Magic where class DataToTag a where dataToTag# :: a -> GHC.Internal.Prim.Int# {-# MINIMAL dataToTag# #-} + considerAccessible :: GHC.Internal.Types.Bool inline :: forall a. a -> a lazy :: forall a. a -> a noinline :: forall a. a -> a @@ -3891,6 +3892,7 @@ module GHC.Tuple where type Unit :: * data Unit = () getSolo :: forall a. Solo a -> a + maxTupleSize :: GHC.Internal.Types.Int module GHC.Types where -- Safety: None View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf2c4caee88d36193c40a04925fa06… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf2c4caee88d36193c40a04925fa06… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] deal with exitification
by sheaf (＠sheaf) 28 Jan '26

28 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: adcbe6b8 by sheaf at 2026-01-27T18:51:24+01:00 deal with exitification - - - - - 4 changed files: - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Types/Id.hs Changes: ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -45,12 +45,14 @@ import GHC.Core.Type import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info +import GHC.Types.Tickish ( GenTickish(..), tickishCanScopeJoin ) + import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Basic( JoinPointHood(..) ) import GHC.Utils.Monad.State.Strict import GHC.Utils.Misc( mapSnd ) +import GHC.Utils.Outputable import GHC.Data.FastString @@ -93,23 +95,23 @@ exitifyProgram binds = map goTopLvl binds where in_scope' = in_scope `extendInScopeSet` bndr - go in_scope (Let (Rec pairs) body) - | is_join_rec = mkLets (exitifyRec in_scope' pairs') body' - | otherwise = Let (Rec pairs') body' + go in_scope (Let (Rec pairs) body) = + case joinPointType_maybe (joinId_maybe . fst) pairs of + Just join_ty -> mkLets (exitifyRec join_ty in_scope' pairs') body' + Nothing -> Let (Rec pairs') body' where - is_join_rec = any (isJoinId . fst) pairs in_scope' = in_scope `extendInScopeSetBind` (Rec pairs) pairs' = mapSnd (go in_scope') pairs body' = go in_scope' body -- | State Monad used inside `exitify` -type ExitifyM = State [(JoinId, CoreExpr)] +type ExitifyM = State [(JoinId, CoreExpr)] -- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as -- join-points outside the joinrec. -exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] -exitifyRec in_scope pairs +exitifyRec :: JoinPointType -> InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] +exitifyRec joinrec_join_ty in_scope pairs = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs'] where -- We need the set of free variables of many subexpressions here, so @@ -124,7 +126,7 @@ exitifyRec in_scope pairs forM ann_pairs $ \(x,rhs) -> do -- go past the lambdas of the join point let (args, body) = collectNAnnBndrs (idJoinArity x) rhs - body' <- go args body + body' <- go joinrec_join_ty args body -- (ExitQuasi2): start with JoinPointType of parent joinrec let rhs' = mkLams args body' return (x, rhs') @@ -135,40 +137,41 @@ exitifyRec in_scope pairs -- variables bound on the way and lifts it out as a join point. -- -- ExitifyM is a state monad to keep track of floated binds - go :: [Var] -- Variables that are in-scope here, but - -- not in scope at the joinrec; that is, - -- we must potentially abstract over them. - -- Invariant: they are kept in dependency order + go :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points] + -> [Var] -- Variables that are in-scope here, but + -- not in scope at the joinrec; that is, + -- we must potentially abstract over them. + -- Invariant: they are kept in dependency order -> CoreExprWithFVs -- Current expression in tail position -> ExitifyM CoreExpr -- We first look at the expression (no matter what it shape is) -- and determine if we can turn it into a exit join point - go captured ann_e + go exit_join_ty captured ann_e | -- An exit expression has no recursive calls let fvs = dVarSetToVarSet (freeVarsOf ann_e) , disjointVarSet fvs recursive_calls - = go_exit captured (deAnnotate ann_e) fvs + = go_exit exit_join_ty captured (deAnnotate ann_e) fvs -- We could not turn it into a exit join point. So now recurse -- into all expression where eligible exit join points might sit, -- i.e. into all tail-call positions: -- Case right hand sides are in tail-call position - go captured (_, AnnCase scrut bndr ty alts) = do + go exit_join_ty captured (_, AnnCase scrut bndr ty alts) = do alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do - rhs' <- go (captured ++ [bndr] ++ pats) rhs + rhs' <- go exit_join_ty (captured ++ [bndr] ++ pats) rhs return (Alt dc pats rhs') return $ Case (deAnnotate scrut) bndr ty alts' - go captured (_, AnnLet ann_bind body) + go exit_join_ty captured (_, AnnLet ann_bind body) -- join point, RHS and body are in tail-call position | AnnNonRec j rhs <- ann_bind , JoinPoint { joinPointArity = join_arity } <- idJoinPointHood j = do let (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ params) join_body + join_body' <- go exit_join_ty (captured ++ params) join_body let rhs' = mkLams params join_body' - body' <- go (captured ++ [j]) body + body' <- go exit_join_ty (captured ++ [j]) body return $ Let (NonRec j rhs') body' -- rec join point, RHSs and body are in tail-call position @@ -178,30 +181,41 @@ exitifyRec in_scope pairs pairs' <- forM pairs $ \(j,rhs) -> do let join_arity = idJoinArity j (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ js ++ params) join_body + join_body' <- go exit_join_ty (captured ++ js ++ params) join_body let rhs' = mkLams params join_body' return (j, rhs') - body' <- go (captured ++ js) body + body' <- go exit_join_ty (captured ++ js) body return $ Let (Rec pairs') body' -- normal Let, only the body is in tail-call position | otherwise - = do body' <- go (captured ++ bindersOf bind ) body + = do body' <- go exit_join_ty (captured ++ bindersOf bind ) body return $ Let bind body' where bind = deAnnBind ann_bind + -- (ExitQuasi1) from Note [Exitification and quasi join points] + go _ captured (_, AnnCast ann_e (_, co)) = do + e' <- go QuasiJoinPoint captured ann_e + return (Cast e' co) + go exit_join_ty captured (_, AnnTick tickish ann_e) + | tickishCanScopeJoin tickish + = Tick tickish <$> go exit_join_ty captured ann_e + | ProfNote {} <- tickish + = Tick tickish <$> go QuasiJoinPoint captured ann_e + -- Cannot be turned into an exit join point, but also has no -- tail-call subexpression. Nothing to do here. - go _ ann_e = return (deAnnotate ann_e) + go _ _ ann_e = return (deAnnotate ann_e) --------------------- - go_exit :: [Var] -- Variables captured locally + go_exit :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points] + -> [Var] -- Variables captured locally -> CoreExpr -- An exit expression -> VarSet -- Free vars of the expression -> ExitifyM CoreExpr -- go_exit deals with a tail expression that is floatable -- out as an exit point; that is, it mentions no recursive calls - go_exit captured e fvs + go_exit exit_join_ty captured e fvs -- Do not touch an expression that is already a join jump where all arguments -- are captured variables. See Note [Idempotency] -- But _do_ float join jumps with interesting arguments. @@ -226,7 +240,7 @@ exitifyRec in_scope pairs let rhs = mkLams abs_vars e avoid = in_scope `extendInScopeSetList` captured -- Remember this binding under a suitable name - ; v <- addExit avoid (length abs_vars) rhs + ; v <- addExit avoid exit_join_ty (length abs_vars) rhs -- And jump to it from here ; return $ mkVarApps (Var v) abs_vars } @@ -263,7 +277,7 @@ exitifyRec in_scope pairs -- * any bound variables (captured) -- * any exit join points created so far. mkExitJoinId :: InScopeSet -> Type -> JoinPointType -> JoinArity -> ExitifyM JoinId -mkExitJoinId in_scope ty join_ty join_arity = do +mkExitJoinId in_scope ty exit_join_ty join_arity = do fs <- get let avoid = in_scope `extendInScopeSetList` (map fst fs) `extendInScopeSet` exit_id_tmpl -- just cosmetics @@ -271,17 +285,65 @@ mkExitJoinId in_scope ty join_ty join_arity = do where exit_id_tmpl = asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty) - join_ty join_arity + exit_join_ty join_arity -addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_arity rhs = do +addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope exit_join_ty join_arity rhs = do -- Pick a suitable name let ty = exprType rhs - v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity + v <- mkExitJoinId in_scope ty exit_join_ty join_arity fs <- get put ((v,rhs):fs) return v +{- Note [Exitification and quasi join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an exit path, we must determine if the new exit join point +should be a true join point or a quasi join point, in the sense of +Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. + +The new exit join point must be a quasi join point if either of the following +conditions apply: + + (ExitQuasi1) The exit path occurs under a cast or a profiling tick. + + (ExitQuasi2) The original joinrec was a quasi join point. + +Rationale for (ExitQuasi1): + + Suppose we have: + + joinrec j x = ... case ... of alts -> e |> co ... in ... + + After exitifying 'e' to 'exit': + + join exit y = e in + joinrec j x = ... case ... of alts -> (exit y) |> co ... in ... + + Because the jump to 'exit' occurs under a cast, 'exit' must be classified + as a quasi join point. + +Rationale for (ExitQuasi2): + + Suppose we have: + + quasijoinrec j x = case x of { 0 -> 100; _ -> j (x-1) } in j 0 |> co + + If we float an exit out of 'j', we end up with + + join exit = 100 in + quasijoinrec j x = case x of { 0 -> exit ; _ -> j (x-1) } in j 0 |> co + + Now suppose we inline j and simplify; we end up with: + + join exit = 100 in exit |> co + + We see now that 'exit' must be a quasi join point, due to the cast. + + Hence: exit join points for a parent quasi join point must themselves be + quasi join points. +-} + {- Note [Interesting expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) import Data.List (mapAccumL) -import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semi {- @@ -4118,10 +4117,7 @@ setBinderOcc occ_info bndr -- See Note [Invariants on join points] in "GHC.Core". decideRecJoinPointHood :: TopLevelFlag -> UsageDetails -> [CoreBndr] -> Maybe JoinPointType -decideRecJoinPointHood lvl usage bndrs = do - bndrsNE <- NE.nonEmpty bndrs - -- Invariant 3: Either all are join points or none are - Semi.sconcat <$> traverse ok bndrsNE +decideRecJoinPointHood lvl usage = joinPointType_maybe ok where ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2056,93 +2056,118 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont of a SpecConstr-generated RULE for a join point. -} --- SLD TODO horrible logic that must be removed -peelJoinResTy :: Int -> Type -> Type -peelJoinResTy 0 ty = ty -peelJoinResTy n ty - | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty - = peelJoinResTy n inner_ty - | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty - = peelJoinResTy (n-1) res_ty - | otherwise - = ty +joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type +joinResTy n0 ty0 = go n0 ty0 + where + go 0 ty = ty + go n ty + | Just (_bndr, res_ty) <- splitPiTy_maybe ty + = go (n-1) res_ty + | otherwise + = pprPanic "joinResTy" $ + vcat [ text "join arity:" <+> ppr n0 + , text "join ty:" <+> ppr ty0 + , text "n:" <+> ppr n + , text "ty:" <+> ppr ty + ] simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplNonRecJoinPoint env bndr rhs body cont +simplNonRecJoinPoint env0 bndr rhs body cont0 = assert (isJoinId bndr) $ - wrapJoinCont do_case_case env cont $ \ env cont -> + wrapJoinCont do_case_case env0 bndr cont0 $ + \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } -> do { -- We push join_cont into the join RHS and the body; -- and wrap wrap_cont around the whole thing - ; let (mult, res_ty) - -- SLD TODO - | Just QuasiJoinPoint <- joinId_maybe bndr - = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr)) - | otherwise - = (contHoleScaling cont, contResultType cont) + let mult = contHoleScaling bind_cont + res_ty = contResultType bind_cont ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) - ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) - ; (floats2, body') <- simplExprF env3 body cont + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont) + ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env) + ; (floats2, body') <- simplExprF env3 body body_cont ; return (floats1 `addFloats` floats2, body') } where do_case_case | Just TrueJoinPoint <- joinId_maybe bndr - = seCaseCase env + = seCaseCase env0 | otherwise = False simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplRecJoinPoint env pairs body cont - = wrapJoinCont do_case_case env cont $ \ env cont -> - do { let bndrs = map fst pairs - (mult, res_ty) - -- SLD TODO - | [b] <- bndrs - , Just QuasiJoinPoint <- joinId_maybe b - = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b)) - | otherwise - = (contHoleScaling cont, contResultType cont) +simplRecJoinPoint env0 pairs body cont0 + = wrapJoinCont do_case_case env0 (head bndrs) cont0 $ + \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } -> + do { let mult = contHoleScaling bind_cont + res_ty = contResultType bind_cont ; env1 <- simplRecJoinBndrs env bndrs mult res_ty -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs - ; (floats2, body') <- simplExprF env2 body cont + ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs + ; (floats2, body') <- simplExprF env2 body body_cont ; return (floats1 `addFloats` floats2, body') } where + bndrs = map fst pairs + do_case_case = - if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs - then seCaseCase env + if all ((== Just TrueJoinPoint) . joinId_maybe) bndrs + then seCaseCase env0 else False -------------------- + +-- | Information computed by 'wrapJoinCont'. +data WrapJoinCont + = WJC + { wjc_bind_env :: !SimplEnv + , wjc_bind_cont :: !SimplCont + , wjc_body_cont :: !SimplCont + } + wrapJoinCont :: Bool - -> SimplEnv -> SimplCont - -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplEnv -> InId -> SimplCont + -> (WrapJoinCont -> SimplM (SimplFloats, OutExpr)) -> SimplM (SimplFloats, OutExpr) -- Deal with making the continuation duplicable if necessary, -- and with the no-case-of-case situation. -wrapJoinCont do_case_case env cont thing_inside +wrapJoinCont do_case_case env join_bndr cont thing_inside | contIsStop cont -- Common case; no need for fancy footwork - = thing_inside env cont + = thing_inside $ + WJC { wjc_bind_env = env + , wjc_bind_cont = if do_case_case then cont else no_case_case_bind_cont + , wjc_body_cont = cont + } | do_case_case -- Normal situation: do the "case-of-case" transformation. -- See Note [Join points and case-of-case]. = do { (floats1, cont') <- mkDupableCont env cont - ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; let wjc = WJC { wjc_bind_env = env `setInScopeFromF` floats1 + , wjc_bind_cont = cont' + , wjc_body_cont = cont' + } + ; (floats2, result) <- thing_inside wjc ; return (floats1 `addFloats` floats2, result) } | otherwise -- No "case-of-case" transformation. -- See Note [Join points with -fno-case-of-case]. - = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + = do { let + wjc = WJC { wjc_bind_env = env + , wjc_bind_cont = no_case_case_bind_cont + , wjc_body_cont = mkBoringStop (contHoleType cont) + } + ; (floats1, expr1) <- thing_inside wjc ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont ; return (floats2 `addFloats` floats3, expr3) } + where + -- See Wrinkle [Casts and join point result types] + join_res_ty = joinResTy (idJoinArity join_bndr) + $ substTy env (idType join_bndr) + no_case_case_bind_cont = mkBoringStop join_res_ty -------------------- trimJoinCont :: Id -- Used only in error message @@ -2282,9 +2307,9 @@ As per Note [Join points and case-of-case], we proceed by first applying the argument to both the join point RHS and the case alternatives: join { j :: Bool -> IO (); j _ = guts arg ] } - in case b of - False -> (scctick<foo> jump j True) arg - True -> jump j False arg + in case b of + False -> (scctick<foo> jump j True) arg + True -> jump j False arg Then we rely on 'trimJoinCont' to remove the argument. In this case, this fails for the first branch, because 'trimJoinCont' doesn't look through profiling @@ -2293,9 +2318,9 @@ end up with, as we don't want to misattribute profiling costs. We could plausibly transform to the following: join { j :: Bool -> IO (); j scc_or_null _ = (setSCC# scc_or_null guts) arg ] } - in case b of - False -> jump j <foo> True - True -> jump j null False + in case b of + False -> jump j <foo> True + True -> jump j null False where `setSCC#` is a new primop that would set the current cost centre pointer (or no-op if the given pointer is null). @@ -2307,17 +2332,17 @@ So instead, for now, we simply disallow the case-of-case transformation for 'j'. Similarly for casts: join { j = blah } - in case e of - False -> j True |> co1 - True -> j False |> co2 + in case e of + False -> j True |> co1 + True -> j False |> co2 if we want to apply this to an argument 'arg', we would need to perform the following transformation: join { j co = ( blah |> co ) arg } - in case e of - False -> j co1 True - True -> j co2 False + in case e of + False -> j co1 True + True -> j co2 False in which we add a coercion argument to the join point. Again, this is not a transformation we currently implement, so we instead prevent case-of-case for @@ -2339,6 +2364,33 @@ we proceed as follows: If we are dealing with a quasi join point, we switch off the case-of-case transformation. +Wrinkle [Casts and join point result types] + + When dealing with a quasi joint-point, we must preserve the original type of + the join point instead of transforming the type (as in Core.Opt.Simplify.Env.adjustJoinPointType). + This is because we don't trim the continuation like we do in + Note [Join points and case-of-case]. + + For example, suppose we have: + + type family F a + + join + j :: forall a. a -> F a + j @a x = ... + in case e of + False -> j @T1 x1 |> ( co1 :: F T1 ~ Int ) + True -> j @T2 x2 |> ( co2 :: F T2 ~ Int ) + + If we used 'contHoleType cont' to compute the result type of 'j', we would + change the result type of 'j' to 'Int', when it needs to remain 'F a'. + + Instead, we avoid doing that and re-compute the result type of 'j' using + 'joinResTy' to get 'F a', as required. + +See also Note [Exitification and quasi join points] in GHC.Core.Opt.Exitify +for another wrinkle. + ************************************************************************ * * Variables ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -79,7 +79,8 @@ module GHC.Types.Id ( -- ** Join variables JoinId, JoinPointHood, - isJoinId, joinId_maybe, idJoinPointHood, idJoinArity, + isJoinId, joinId_maybe, joinPointType_maybe, + idJoinPointHood, idJoinArity, asJoinId, asJoinId_maybe, zapJoinId, -- ** Inline pragma stuff @@ -172,6 +173,8 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as Semi -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, @@ -584,6 +587,13 @@ joinId_maybe id _ -> Nothing | otherwise = Nothing +joinPointType_maybe :: (a -> Maybe JoinPointType) -> [a] -> Maybe JoinPointType +joinPointType_maybe f xs = do + xsNE <- NE.nonEmpty xs + Semi.sconcat <$> traverse f xsNE + -- traverse: either all are join points or none are + -- sconcat: only a 'TrueJoinPoint' if all are + -- | Doesn't return strictness marks idJoinPointHood :: Var -> JoinPointHood idJoinPointHood id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/adcbe6b80360c09a27508f7d09203de… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/adcbe6b80360c09a27508f7d09203de… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] deal with exitification
by sheaf (＠sheaf) 28 Jan '26

28 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: 77386709 by sheaf at 2026-01-27T18:46:12+01:00 deal with exitification - - - - - 4 changed files: - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Types/Id.hs Changes: ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -45,12 +45,14 @@ import GHC.Core.Type import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info +import GHC.Types.Tickish ( GenTickish(..), tickishCanScopeJoin ) + import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Basic( JoinPointHood(..) ) import GHC.Utils.Monad.State.Strict import GHC.Utils.Misc( mapSnd ) +import GHC.Utils.Outputable import GHC.Data.FastString @@ -93,23 +95,23 @@ exitifyProgram binds = map goTopLvl binds where in_scope' = in_scope `extendInScopeSet` bndr - go in_scope (Let (Rec pairs) body) - | is_join_rec = mkLets (exitifyRec in_scope' pairs') body' - | otherwise = Let (Rec pairs') body' + go in_scope (Let (Rec pairs) body) = + case joinPointType_maybe (joinId_maybe . fst) pairs of + Just join_ty -> mkLets (exitifyRec join_ty in_scope' pairs') body' + Nothing -> Let (Rec pairs') body' where - is_join_rec = any (isJoinId . fst) pairs in_scope' = in_scope `extendInScopeSetBind` (Rec pairs) pairs' = mapSnd (go in_scope') pairs body' = go in_scope' body -- | State Monad used inside `exitify` -type ExitifyM = State [(JoinId, CoreExpr)] +type ExitifyM = State [(JoinId, CoreExpr)] -- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as -- join-points outside the joinrec. -exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] -exitifyRec in_scope pairs +exitifyRec :: JoinPointType -> InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] +exitifyRec joinrec_join_ty in_scope pairs = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs'] where -- We need the set of free variables of many subexpressions here, so @@ -124,7 +126,7 @@ exitifyRec in_scope pairs forM ann_pairs $ \(x,rhs) -> do -- go past the lambdas of the join point let (args, body) = collectNAnnBndrs (idJoinArity x) rhs - body' <- go args body + body' <- go joinrec_join_ty args body -- (ExitJoin2): start with JoinPointType of parent joinrec let rhs' = mkLams args body' return (x, rhs') @@ -135,40 +137,41 @@ exitifyRec in_scope pairs -- variables bound on the way and lifts it out as a join point. -- -- ExitifyM is a state monad to keep track of floated binds - go :: [Var] -- Variables that are in-scope here, but - -- not in scope at the joinrec; that is, - -- we must potentially abstract over them. - -- Invariant: they are kept in dependency order + go :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points] + -> [Var] -- Variables that are in-scope here, but + -- not in scope at the joinrec; that is, + -- we must potentially abstract over them. + -- Invariant: they are kept in dependency order -> CoreExprWithFVs -- Current expression in tail position -> ExitifyM CoreExpr -- We first look at the expression (no matter what it shape is) -- and determine if we can turn it into a exit join point - go captured ann_e + go exit_join_ty captured ann_e | -- An exit expression has no recursive calls let fvs = dVarSetToVarSet (freeVarsOf ann_e) , disjointVarSet fvs recursive_calls - = go_exit captured (deAnnotate ann_e) fvs + = go_exit exit_join_ty captured (deAnnotate ann_e) fvs -- We could not turn it into a exit join point. So now recurse -- into all expression where eligible exit join points might sit, -- i.e. into all tail-call positions: -- Case right hand sides are in tail-call position - go captured (_, AnnCase scrut bndr ty alts) = do + go exit_join_ty captured (_, AnnCase scrut bndr ty alts) = do alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do - rhs' <- go (captured ++ [bndr] ++ pats) rhs + rhs' <- go exit_join_ty (captured ++ [bndr] ++ pats) rhs return (Alt dc pats rhs') return $ Case (deAnnotate scrut) bndr ty alts' - go captured (_, AnnLet ann_bind body) + go exit_join_ty captured (_, AnnLet ann_bind body) -- join point, RHS and body are in tail-call position | AnnNonRec j rhs <- ann_bind , JoinPoint { joinPointArity = join_arity } <- idJoinPointHood j = do let (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ params) join_body + join_body' <- go exit_join_ty (captured ++ params) join_body let rhs' = mkLams params join_body' - body' <- go (captured ++ [j]) body + body' <- go exit_join_ty (captured ++ [j]) body return $ Let (NonRec j rhs') body' -- rec join point, RHSs and body are in tail-call position @@ -178,30 +181,41 @@ exitifyRec in_scope pairs pairs' <- forM pairs $ \(j,rhs) -> do let join_arity = idJoinArity j (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ js ++ params) join_body + join_body' <- go exit_join_ty (captured ++ js ++ params) join_body let rhs' = mkLams params join_body' return (j, rhs') - body' <- go (captured ++ js) body + body' <- go exit_join_ty (captured ++ js) body return $ Let (Rec pairs') body' -- normal Let, only the body is in tail-call position | otherwise - = do body' <- go (captured ++ bindersOf bind ) body + = do body' <- go exit_join_ty (captured ++ bindersOf bind ) body return $ Let bind body' where bind = deAnnBind ann_bind + -- (ExitJoin1) from Note [Exitification and quasi join points] + go _ captured (_, AnnCast ann_e (_, co)) = do + e' <- go QuasiJoinPoint captured ann_e + return (Cast e' co) + go exit_join_ty captured (_, AnnTick tickish ann_e) + | tickishCanScopeJoin tickish + = Tick tickish <$> go exit_join_ty captured ann_e + | ProfNote {} <- tickish + = Tick tickish <$> go QuasiJoinPoint captured ann_e + -- Cannot be turned into an exit join point, but also has no -- tail-call subexpression. Nothing to do here. - go _ ann_e = return (deAnnotate ann_e) + go _ _ ann_e = return (deAnnotate ann_e) --------------------- - go_exit :: [Var] -- Variables captured locally + go_exit :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points] + -> [Var] -- Variables captured locally -> CoreExpr -- An exit expression -> VarSet -- Free vars of the expression -> ExitifyM CoreExpr -- go_exit deals with a tail expression that is floatable -- out as an exit point; that is, it mentions no recursive calls - go_exit captured e fvs + go_exit exit_join_ty captured e fvs -- Do not touch an expression that is already a join jump where all arguments -- are captured variables. See Note [Idempotency] -- But _do_ float join jumps with interesting arguments. @@ -226,7 +240,7 @@ exitifyRec in_scope pairs let rhs = mkLams abs_vars e avoid = in_scope `extendInScopeSetList` captured -- Remember this binding under a suitable name - ; v <- addExit avoid (length abs_vars) rhs + ; v <- addExit avoid exit_join_ty (length abs_vars) rhs -- And jump to it from here ; return $ mkVarApps (Var v) abs_vars } @@ -263,7 +277,7 @@ exitifyRec in_scope pairs -- * any bound variables (captured) -- * any exit join points created so far. mkExitJoinId :: InScopeSet -> Type -> JoinPointType -> JoinArity -> ExitifyM JoinId -mkExitJoinId in_scope ty join_ty join_arity = do +mkExitJoinId in_scope ty exit_join_ty join_arity = do fs <- get let avoid = in_scope `extendInScopeSetList` (map fst fs) `extendInScopeSet` exit_id_tmpl -- just cosmetics @@ -271,17 +285,65 @@ mkExitJoinId in_scope ty join_ty join_arity = do where exit_id_tmpl = asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty) - join_ty join_arity + exit_join_ty join_arity -addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_arity rhs = do +addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope exit_join_ty join_arity rhs = do -- Pick a suitable name let ty = exprType rhs - v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity + v <- mkExitJoinId in_scope ty exit_join_ty join_arity fs <- get put ((v,rhs):fs) return v +{- Note [Exitification and quasi join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an exit path, we must determine if the new exit join point +should be a true join point or a quasi join point, in the sense of +Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. + +The new exit join point must be a quasi join point if either of the following +conditions apply: + + (ExitJoin1) The exit path occurs under a cast or a profiling tick. + + (ExitJoin2) The original joinrec was a quasi join point. + +Rationale for (ExitJoin1): + + Suppose we have: + + joinrec j x = ... case ... of alts -> e |> co ... in ... + + After exitifying 'e' to 'exit': + + join exit y = e in + joinrec j x = ... case ... of alts -> (exit y) |> co ... in ... + + Because the jump to 'exit' occurs under a cast, 'exit' must be classified + as a quasi join point. + +Rationale for (ExitJoin2): + + Suppose we have: + + quasijoinrec j x = case x of { 0 -> 100; _ -> j (x-1) } in j 0 |> co + + If we float an exit out of 'j', we end up with + + join exit = 100 in + quasijoinrec j x = case x of { 0 -> exit ; _ -> j (x-1) } in j 0 |> co + + Now suppose we inline j and simplify; we end up with: + + join exit = 100 in exit |> co + + We see now that 'exit' must be a quasi join point, due to the cast. + + Hence: exit join points for a parent quasi join point must themselves be + quasi join points. +-} + {- Note [Interesting expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) import Data.List (mapAccumL) -import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semi {- @@ -4118,10 +4117,7 @@ setBinderOcc occ_info bndr -- See Note [Invariants on join points] in "GHC.Core". decideRecJoinPointHood :: TopLevelFlag -> UsageDetails -> [CoreBndr] -> Maybe JoinPointType -decideRecJoinPointHood lvl usage bndrs = do - bndrsNE <- NE.nonEmpty bndrs - -- Invariant 3: Either all are join points or none are - Semi.sconcat <$> traverse ok bndrsNE +decideRecJoinPointHood lvl usage = joinPointType_maybe ok where ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2056,93 +2056,118 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont of a SpecConstr-generated RULE for a join point. -} --- SLD TODO horrible logic that must be removed -peelJoinResTy :: Int -> Type -> Type -peelJoinResTy 0 ty = ty -peelJoinResTy n ty - | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty - = peelJoinResTy n inner_ty - | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty - = peelJoinResTy (n-1) res_ty - | otherwise - = ty +joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type +joinResTy n0 ty0 = go n0 ty0 + where + go 0 ty = ty + go n ty + | Just (_bndr, res_ty) <- splitPiTy_maybe ty + = go (n-1) res_ty + | otherwise + = pprPanic "joinResTy" $ + vcat [ text "join arity:" <+> ppr n0 + , text "join ty:" <+> ppr ty0 + , text "n:" <+> ppr n + , text "ty:" <+> ppr ty + ] simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplNonRecJoinPoint env bndr rhs body cont +simplNonRecJoinPoint env0 bndr rhs body cont0 = assert (isJoinId bndr) $ - wrapJoinCont do_case_case env cont $ \ env cont -> + wrapJoinCont do_case_case env0 bndr cont0 $ + \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } -> do { -- We push join_cont into the join RHS and the body; -- and wrap wrap_cont around the whole thing - ; let (mult, res_ty) - -- SLD TODO - | Just QuasiJoinPoint <- joinId_maybe bndr - = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr)) - | otherwise - = (contHoleScaling cont, contResultType cont) + let mult = contHoleScaling bind_cont + res_ty = contResultType bind_cont ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) - ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) - ; (floats2, body') <- simplExprF env3 body cont + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont) + ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env) + ; (floats2, body') <- simplExprF env3 body body_cont ; return (floats1 `addFloats` floats2, body') } where do_case_case | Just TrueJoinPoint <- joinId_maybe bndr - = seCaseCase env + = seCaseCase env0 | otherwise = False simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplRecJoinPoint env pairs body cont - = wrapJoinCont do_case_case env cont $ \ env cont -> - do { let bndrs = map fst pairs - (mult, res_ty) - -- SLD TODO - | [b] <- bndrs - , Just QuasiJoinPoint <- joinId_maybe b - = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b)) - | otherwise - = (contHoleScaling cont, contResultType cont) +simplRecJoinPoint env0 pairs body cont0 + = wrapJoinCont do_case_case env0 (head bndrs) cont0 $ + \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } -> + do { let mult = contHoleScaling bind_cont + res_ty = contResultType bind_cont ; env1 <- simplRecJoinBndrs env bndrs mult res_ty -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs - ; (floats2, body') <- simplExprF env2 body cont + ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs + ; (floats2, body') <- simplExprF env2 body body_cont ; return (floats1 `addFloats` floats2, body') } where + bndrs = map fst pairs + do_case_case = - if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs - then seCaseCase env + if all ((== Just TrueJoinPoint) . joinId_maybe) bndrs + then seCaseCase env0 else False -------------------- + +-- | Information computed by 'wrapJoinCont'. +data WrapJoinCont + = WJC + { wjc_bind_env :: !SimplEnv + , wjc_bind_cont :: !SimplCont + , wjc_body_cont :: !SimplCont + } + wrapJoinCont :: Bool - -> SimplEnv -> SimplCont - -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplEnv -> InId -> SimplCont + -> (WrapJoinCont -> SimplM (SimplFloats, OutExpr)) -> SimplM (SimplFloats, OutExpr) -- Deal with making the continuation duplicable if necessary, -- and with the no-case-of-case situation. -wrapJoinCont do_case_case env cont thing_inside +wrapJoinCont do_case_case env join_bndr cont thing_inside | contIsStop cont -- Common case; no need for fancy footwork - = thing_inside env cont + = thing_inside $ + WJC { wjc_bind_env = env + , wjc_bind_cont = if do_case_case then cont else no_case_case_bind_cont + , wjc_body_cont = cont + } | do_case_case -- Normal situation: do the "case-of-case" transformation. -- See Note [Join points and case-of-case]. = do { (floats1, cont') <- mkDupableCont env cont - ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; let wjc = WJC { wjc_bind_env = env `setInScopeFromF` floats1 + , wjc_bind_cont = cont' + , wjc_body_cont = cont' + } + ; (floats2, result) <- thing_inside wjc ; return (floats1 `addFloats` floats2, result) } | otherwise -- No "case-of-case" transformation. -- See Note [Join points with -fno-case-of-case]. - = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + = do { let + wjc = WJC { wjc_bind_env = env + , wjc_bind_cont = no_case_case_bind_cont + , wjc_body_cont = mkBoringStop (contHoleType cont) + } + ; (floats1, expr1) <- thing_inside wjc ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont ; return (floats2 `addFloats` floats3, expr3) } + where + -- See Wrinkle [Casts and join point result types] + join_res_ty = joinResTy (idJoinArity join_bndr) + $ substTy env (idType join_bndr) + no_case_case_bind_cont = mkBoringStop join_res_ty -------------------- trimJoinCont :: Id -- Used only in error message @@ -2282,9 +2307,9 @@ As per Note [Join points and case-of-case], we proceed by first applying the argument to both the join point RHS and the case alternatives: join { j :: Bool -> IO (); j _ = guts arg ] } - in case b of - False -> (scctick<foo> jump j True) arg - True -> jump j False arg + in case b of + False -> (scctick<foo> jump j True) arg + True -> jump j False arg Then we rely on 'trimJoinCont' to remove the argument. In this case, this fails for the first branch, because 'trimJoinCont' doesn't look through profiling @@ -2293,9 +2318,9 @@ end up with, as we don't want to misattribute profiling costs. We could plausibly transform to the following: join { j :: Bool -> IO (); j scc_or_null _ = (setSCC# scc_or_null guts) arg ] } - in case b of - False -> jump j <foo> True - True -> jump j null False + in case b of + False -> jump j <foo> True + True -> jump j null False where `setSCC#` is a new primop that would set the current cost centre pointer (or no-op if the given pointer is null). @@ -2307,17 +2332,17 @@ So instead, for now, we simply disallow the case-of-case transformation for 'j'. Similarly for casts: join { j = blah } - in case e of - False -> j True |> co1 - True -> j False |> co2 + in case e of + False -> j True |> co1 + True -> j False |> co2 if we want to apply this to an argument 'arg', we would need to perform the following transformation: join { j co = ( blah |> co ) arg } - in case e of - False -> j co1 True - True -> j co2 False + in case e of + False -> j co1 True + True -> j co2 False in which we add a coercion argument to the join point. Again, this is not a transformation we currently implement, so we instead prevent case-of-case for @@ -2339,6 +2364,33 @@ we proceed as follows: If we are dealing with a quasi join point, we switch off the case-of-case transformation. +Wrinkle [Casts and join point result types] + + When dealing with a quasi joint-point, we must preserve the original type of + the join point instead of transforming the type (as in Core.Opt.Simplify.Env.adjustJoinPointType). + This is because we don't trim the continuation like we do in + Note [Join points and case-of-case]. + + For example, suppose we have: + + type family F a + + join + j :: forall a. a -> F a + j @a x = ... + in case e of + False -> j @T1 x1 |> ( co1 :: F T1 ~ Int ) + True -> j @T2 x2 |> ( co2 :: F T2 ~ Int ) + + If we used 'contHoleType cont' to compute the result type of 'j', we would + change the result type of 'j' to 'Int', when it needs to remain 'F a'. + + Instead, we avoid doing that and re-compute the result type of 'j' using + 'joinResTy' to get 'F a', as required. + +See also Note [Exitification and quasi join points] in GHC.Core.Opt.Exitify +for another wrinkle. + ************************************************************************ * * Variables ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -79,7 +79,8 @@ module GHC.Types.Id ( -- ** Join variables JoinId, JoinPointHood, - isJoinId, joinId_maybe, idJoinPointHood, idJoinArity, + isJoinId, joinId_maybe, joinPointType_maybe, + idJoinPointHood, idJoinArity, asJoinId, asJoinId_maybe, zapJoinId, -- ** Inline pragma stuff @@ -172,6 +173,8 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as Semi -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, @@ -584,6 +587,13 @@ joinId_maybe id _ -> Nothing | otherwise = Nothing +joinPointType_maybe :: (a -> Maybe JoinPointType) -> [a] -> Maybe JoinPointType +joinPointType_maybe f xs = do + xsNE <- NE.nonEmpty xs + Semi.sconcat <$> traverse f xsNE + -- traverse: either all are join points or none are + -- sconcat: only a 'TrueJoinPoint' if all are + -- | Doesn't return strictness marks idJoinPointHood :: Var -> JoinPointHood idJoinPointHood id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77386709e6160e7a7283f4f0ba20aa4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77386709e6160e7a7283f4f0ba20aa4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] deal with exitification
by sheaf (＠sheaf) 28 Jan '26

28 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: 678d8950 by sheaf at 2026-01-27T18:45:58+01:00 deal with exitification - - - - - 4 changed files: - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Types/Id.hs Changes: ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -45,12 +45,14 @@ import GHC.Core.Type import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info +import GHC.Types.Tickish ( GenTickish(..), tickishCanScopeJoin ) + import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Basic( JoinPointHood(..) ) import GHC.Utils.Monad.State.Strict import GHC.Utils.Misc( mapSnd ) +import GHC.Utils.Outputable import GHC.Data.FastString @@ -93,23 +95,23 @@ exitifyProgram binds = map goTopLvl binds where in_scope' = in_scope `extendInScopeSet` bndr - go in_scope (Let (Rec pairs) body) - | is_join_rec = mkLets (exitifyRec in_scope' pairs') body' - | otherwise = Let (Rec pairs') body' + go in_scope (Let (Rec pairs) body) = + case joinPointType_maybe (joinId_maybe . fst) pairs of + Just join_ty -> mkLets (exitifyRec join_ty in_scope' pairs') body' + Nothing -> Let (Rec pairs') body' where - is_join_rec = any (isJoinId . fst) pairs in_scope' = in_scope `extendInScopeSetBind` (Rec pairs) pairs' = mapSnd (go in_scope') pairs body' = go in_scope' body -- | State Monad used inside `exitify` -type ExitifyM = State [(JoinId, CoreExpr)] +type ExitifyM = State [(JoinId, CoreExpr)] -- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as -- join-points outside the joinrec. -exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] -exitifyRec in_scope pairs +exitifyRec :: JoinPointType -> InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] +exitifyRec joinrec_join_ty in_scope pairs = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs'] where -- We need the set of free variables of many subexpressions here, so @@ -124,7 +126,7 @@ exitifyRec in_scope pairs forM ann_pairs $ \(x,rhs) -> do -- go past the lambdas of the join point let (args, body) = collectNAnnBndrs (idJoinArity x) rhs - body' <- go args body + body' <- go joinrec_join_ty args body -- (ExitJoin2): start with JoinPointType of parent joinrec let rhs' = mkLams args body' return (x, rhs') @@ -135,40 +137,41 @@ exitifyRec in_scope pairs -- variables bound on the way and lifts it out as a join point. -- -- ExitifyM is a state monad to keep track of floated binds - go :: [Var] -- Variables that are in-scope here, but - -- not in scope at the joinrec; that is, - -- we must potentially abstract over them. - -- Invariant: they are kept in dependency order + go :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points] + -> [Var] -- Variables that are in-scope here, but + -- not in scope at the joinrec; that is, + -- we must potentially abstract over them. + -- Invariant: they are kept in dependency order -> CoreExprWithFVs -- Current expression in tail position -> ExitifyM CoreExpr -- We first look at the expression (no matter what it shape is) -- and determine if we can turn it into a exit join point - go captured ann_e + go exit_join_ty captured ann_e | -- An exit expression has no recursive calls let fvs = dVarSetToVarSet (freeVarsOf ann_e) , disjointVarSet fvs recursive_calls - = go_exit captured (deAnnotate ann_e) fvs + = go_exit exit_join_ty captured (deAnnotate ann_e) fvs -- We could not turn it into a exit join point. So now recurse -- into all expression where eligible exit join points might sit, -- i.e. into all tail-call positions: -- Case right hand sides are in tail-call position - go captured (_, AnnCase scrut bndr ty alts) = do + go exit_join_ty captured (_, AnnCase scrut bndr ty alts) = do alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do - rhs' <- go (captured ++ [bndr] ++ pats) rhs + rhs' <- go exit_join_ty (captured ++ [bndr] ++ pats) rhs return (Alt dc pats rhs') return $ Case (deAnnotate scrut) bndr ty alts' - go captured (_, AnnLet ann_bind body) + go exit_join_ty captured (_, AnnLet ann_bind body) -- join point, RHS and body are in tail-call position | AnnNonRec j rhs <- ann_bind , JoinPoint { joinPointArity = join_arity } <- idJoinPointHood j = do let (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ params) join_body + join_body' <- go exit_join_ty (captured ++ params) join_body let rhs' = mkLams params join_body' - body' <- go (captured ++ [j]) body + body' <- go exit_join_ty (captured ++ [j]) body return $ Let (NonRec j rhs') body' -- rec join point, RHSs and body are in tail-call position @@ -178,30 +181,41 @@ exitifyRec in_scope pairs pairs' <- forM pairs $ \(j,rhs) -> do let join_arity = idJoinArity j (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ js ++ params) join_body + join_body' <- go exit_join_ty (captured ++ js ++ params) join_body let rhs' = mkLams params join_body' return (j, rhs') - body' <- go (captured ++ js) body + body' <- go exit_join_ty (captured ++ js) body return $ Let (Rec pairs') body' -- normal Let, only the body is in tail-call position | otherwise - = do body' <- go (captured ++ bindersOf bind ) body + = do body' <- go exit_join_ty (captured ++ bindersOf bind ) body return $ Let bind body' where bind = deAnnBind ann_bind + -- (ExitJoin1) from Note [Exitification and quasi join points] + go _ captured (_, AnnCast ann_e (_, co)) = do + e' <- go QuasiJoinPoint captured ann_e + return (Cast e' co) + go exit_join_ty captured (_, AnnTick tickish ann_e) + | tickishCanScopeJoin tickish + = Tick tickish <$> go exit_join_ty captured ann_e + | ProfNote {} <- tickish + = Tick tickish <$> go QuasiJoinPoint captured ann_e + -- Cannot be turned into an exit join point, but also has no -- tail-call subexpression. Nothing to do here. - go _ ann_e = return (deAnnotate ann_e) + go _ _ ann_e = return (deAnnotate ann_e) --------------------- - go_exit :: [Var] -- Variables captured locally + go_exit :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points] + -> [Var] -- Variables captured locally -> CoreExpr -- An exit expression -> VarSet -- Free vars of the expression -> ExitifyM CoreExpr -- go_exit deals with a tail expression that is floatable -- out as an exit point; that is, it mentions no recursive calls - go_exit captured e fvs + go_exit exit_join_ty captured e fvs -- Do not touch an expression that is already a join jump where all arguments -- are captured variables. See Note [Idempotency] -- But _do_ float join jumps with interesting arguments. @@ -226,7 +240,7 @@ exitifyRec in_scope pairs let rhs = mkLams abs_vars e avoid = in_scope `extendInScopeSetList` captured -- Remember this binding under a suitable name - ; v <- addExit avoid (length abs_vars) rhs + ; v <- addExit avoid exit_join_ty (length abs_vars) rhs -- And jump to it from here ; return $ mkVarApps (Var v) abs_vars } @@ -263,7 +277,7 @@ exitifyRec in_scope pairs -- * any bound variables (captured) -- * any exit join points created so far. mkExitJoinId :: InScopeSet -> Type -> JoinPointType -> JoinArity -> ExitifyM JoinId -mkExitJoinId in_scope ty join_ty join_arity = do +mkExitJoinId in_scope ty exit_join_ty join_arity = do fs <- get let avoid = in_scope `extendInScopeSetList` (map fst fs) `extendInScopeSet` exit_id_tmpl -- just cosmetics @@ -271,17 +285,65 @@ mkExitJoinId in_scope ty join_ty join_arity = do where exit_id_tmpl = asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty) - join_ty join_arity + exit_join_ty join_arity -addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_arity rhs = do +addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope exit_join_ty join_arity rhs = do -- Pick a suitable name let ty = exprType rhs - v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity + v <- mkExitJoinId in_scope ty exit_join_ty join_arity fs <- get put ((v,rhs):fs) return v +{- Note [Exitification and quasi join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an exit path, we must determine if the new exit join point +should be a true join point or a quasi join point, in the sense of +Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration). + +The new exit join point must be a quasi join point if either of the following +conditions apply: + + (ExitJoin1) The exit path occurs under a cast or a profiling tick. + + (ExitJoin2) The original joinrec was a quasi join point. + +Rationale for (ExitJoin1): + + Suppose we have: + + joinrec j x = ... case ... of alts -> e |> co ... in ... + + After exitifying 'e' to 'exit': + + join exit y = e in + joinrec j x = ... case ... of alts -> (exit y) |> co ... in ... + + Because the jump to 'exit' occurs under a cast, 'exit' must be classified + as a quasi join point. + +Rationale for (ExitJoin2): + + Suppose we have: + + quasijoinrec j x = case x of { 0 -> 100; _ -> j (x-1) } in j 0 |> co + + If we float an exit out of 'j', we end up with + + join exit = 100 in + quasijoinrec j x = case x of { 0 -> exit ; _ -> j (x-1) } in j 0 |> co + + Now suppose we inline j and simplify; we end up with: + + join exit = 100 in exit |> co + + We see now that 'exit' must be a quasi join point, due to the cast. + + Hence: exit join points for a parent quasi join point must themselves be + quasi join points. +-} + {- Note [Interesting expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) import Data.List (mapAccumL) -import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semi {- @@ -4118,10 +4117,7 @@ setBinderOcc occ_info bndr -- See Note [Invariants on join points] in "GHC.Core". decideRecJoinPointHood :: TopLevelFlag -> UsageDetails -> [CoreBndr] -> Maybe JoinPointType -decideRecJoinPointHood lvl usage bndrs = do - bndrsNE <- NE.nonEmpty bndrs - -- Invariant 3: Either all are join points or none are - Semi.sconcat <$> traverse ok bndrsNE +decideRecJoinPointHood lvl usage = joinPointType_maybe ok where ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2056,93 +2056,118 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont of a SpecConstr-generated RULE for a join point. -} --- SLD TODO horrible logic that must be removed -peelJoinResTy :: Int -> Type -> Type -peelJoinResTy 0 ty = ty -peelJoinResTy n ty - | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty - = peelJoinResTy n inner_ty - | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty - = peelJoinResTy (n-1) res_ty - | otherwise - = ty +joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type +joinResTy n0 ty0 = go n0 ty0 + where + go 0 ty = ty + go n ty + | Just (_bndr, res_ty) <- splitPiTy_maybe ty + = go (n-1) res_ty + | otherwise + = pprPanic "joinResTy" $ + vcat [ text "join arity:" <+> ppr n0 + , text "join ty:" <+> ppr ty0 + , text "n:" <+> ppr n + , text "ty:" <+> ppr ty + ] simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplNonRecJoinPoint env bndr rhs body cont +simplNonRecJoinPoint env0 bndr rhs body cont0 = assert (isJoinId bndr) $ - wrapJoinCont do_case_case env cont $ \ env cont -> + wrapJoinCont do_case_case env0 bndr cont0 $ + \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } -> do { -- We push join_cont into the join RHS and the body; -- and wrap wrap_cont around the whole thing - ; let (mult, res_ty) - -- SLD TODO - | Just QuasiJoinPoint <- joinId_maybe bndr - = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr)) - | otherwise - = (contHoleScaling cont, contResultType cont) + let mult = contHoleScaling bind_cont + res_ty = contResultType bind_cont ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) - ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) - ; (floats2, body') <- simplExprF env3 body cont + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont) + ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env) + ; (floats2, body') <- simplExprF env3 body body_cont ; return (floats1 `addFloats` floats2, body') } where do_case_case | Just TrueJoinPoint <- joinId_maybe bndr - = seCaseCase env + = seCaseCase env0 | otherwise = False simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplRecJoinPoint env pairs body cont - = wrapJoinCont do_case_case env cont $ \ env cont -> - do { let bndrs = map fst pairs - (mult, res_ty) - -- SLD TODO - | [b] <- bndrs - , Just QuasiJoinPoint <- joinId_maybe b - = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b)) - | otherwise - = (contHoleScaling cont, contResultType cont) +simplRecJoinPoint env0 pairs body cont0 + = wrapJoinCont do_case_case env0 (head bndrs) cont0 $ + \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } -> + do { let mult = contHoleScaling bind_cont + res_ty = contResultType bind_cont ; env1 <- simplRecJoinBndrs env bndrs mult res_ty -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs - ; (floats2, body') <- simplExprF env2 body cont + ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs + ; (floats2, body') <- simplExprF env2 body body_cont ; return (floats1 `addFloats` floats2, body') } where + bndrs = map fst pairs + do_case_case = - if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs - then seCaseCase env + if all ((== Just TrueJoinPoint) . joinId_maybe) bndrs + then seCaseCase env0 else False -------------------- + +-- | Information computed by 'wrapJoinCont'. +data WrapJoinCont + = WJC + { wjc_bind_env :: !SimplEnv + , wjc_bind_cont :: !SimplCont + , wjc_body_cont :: !SimplCont + } + wrapJoinCont :: Bool - -> SimplEnv -> SimplCont - -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplEnv -> InId -> SimplCont + -> (WrapJoinCont -> SimplM (SimplFloats, OutExpr)) -> SimplM (SimplFloats, OutExpr) -- Deal with making the continuation duplicable if necessary, -- and with the no-case-of-case situation. -wrapJoinCont do_case_case env cont thing_inside +wrapJoinCont do_case_case env join_bndr cont thing_inside | contIsStop cont -- Common case; no need for fancy footwork - = thing_inside env cont + = thing_inside $ + WJC { wjc_bind_env = env + , wjc_bind_cont = if do_case_case then cont else no_case_case_bind_cont + , wjc_body_cont = cont + } | do_case_case -- Normal situation: do the "case-of-case" transformation. -- See Note [Join points and case-of-case]. = do { (floats1, cont') <- mkDupableCont env cont - ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; let wjc = WJC { wjc_bind_env = env `setInScopeFromF` floats1 + , wjc_bind_cont = cont' + , wjc_body_cont = cont' + } + ; (floats2, result) <- thing_inside wjc ; return (floats1 `addFloats` floats2, result) } | otherwise -- No "case-of-case" transformation. -- See Note [Join points with -fno-case-of-case]. - = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + = do { let + wjc = WJC { wjc_bind_env = env + , wjc_bind_cont = no_case_case_bind_cont + , wjc_body_cont = mkBoringStop (contHoleType cont) + } + ; (floats1, expr1) <- thing_inside wjc ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont ; return (floats2 `addFloats` floats3, expr3) } + where + -- See Wrinkle [Casts and join point result types] + join_res_ty = joinResTy (idJoinArity join_bndr) + $ substTy env (idType join_bndr) + no_case_case_bind_cont = mkBoringStop join_res_ty -------------------- trimJoinCont :: Id -- Used only in error message @@ -2282,9 +2307,9 @@ As per Note [Join points and case-of-case], we proceed by first applying the argument to both the join point RHS and the case alternatives: join { j :: Bool -> IO (); j _ = guts arg ] } - in case b of - False -> (scctick<foo> jump j True) arg - True -> jump j False arg + in case b of + False -> (scctick<foo> jump j True) arg + True -> jump j False arg Then we rely on 'trimJoinCont' to remove the argument. In this case, this fails for the first branch, because 'trimJoinCont' doesn't look through profiling @@ -2293,9 +2318,9 @@ end up with, as we don't want to misattribute profiling costs. We could plausibly transform to the following: join { j :: Bool -> IO (); j scc_or_null _ = (setSCC# scc_or_null guts) arg ] } - in case b of - False -> jump j <foo> True - True -> jump j null False + in case b of + False -> jump j <foo> True + True -> jump j null False where `setSCC#` is a new primop that would set the current cost centre pointer (or no-op if the given pointer is null). @@ -2307,17 +2332,17 @@ So instead, for now, we simply disallow the case-of-case transformation for 'j'. Similarly for casts: join { j = blah } - in case e of - False -> j True |> co1 - True -> j False |> co2 + in case e of + False -> j True |> co1 + True -> j False |> co2 if we want to apply this to an argument 'arg', we would need to perform the following transformation: join { j co = ( blah |> co ) arg } - in case e of - False -> j co1 True - True -> j co2 False + in case e of + False -> j co1 True + True -> j co2 False in which we add a coercion argument to the join point. Again, this is not a transformation we currently implement, so we instead prevent case-of-case for @@ -2339,6 +2364,33 @@ we proceed as follows: If we are dealing with a quasi join point, we switch off the case-of-case transformation. +Wrinkle [Casts and join point result types] + + When dealing with a quasi joint-point, we must preserve the original type of + the join point instead of transforming the type (as in Core.Opt.Simplify.Env.adjustJoinPointType). + This is because we don't trim the continuation like we do in + Note [Join points and case-of-case]. + + For example, suppose we have: + + type family F a + + join + j :: forall a. a -> F a + j @a x = ... + in case e of + False -> j @T1 x1 |> ( co1 :: F T1 ~ Int ) + True -> j @T2 x2 |> ( co2 :: F T2 ~ Int ) + + If we used 'contHoleType cont' to compute the result type of 'j', we would + change the result type of 'j' to 'Int', when it needs to remain 'F a'. + + Instead, we avoid doing that and re-compute the result type of 'j' using + 'joinResTy' to get 'F a', as required. + +See also Note [Exitification and quasi join points] in GHC.Core.Opt.Exitify +for another wrinkle. + ************************************************************************ * * Variables ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -79,7 +79,8 @@ module GHC.Types.Id ( -- ** Join variables JoinId, JoinPointHood, - isJoinId, joinId_maybe, idJoinPointHood, idJoinArity, + isJoinId, joinId_maybe, joinPointType_maybe, + idJoinPointHood, idJoinArity, asJoinId, asJoinId_maybe, zapJoinId, -- ** Inline pragma stuff @@ -172,6 +173,8 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as Semi -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, @@ -584,6 +587,13 @@ joinId_maybe id _ -> Nothing | otherwise = Nothing +joinPointType_maybe :: (a -> Maybe JoinPointType) -> [a] -> Maybe JoinPointType +joinPointType_maybe f xs = do + xsNE <- NE.nonEmpty xs + Semi.sconcat <$> traverse f xsNE + -- traverse: either all are join points or none are + -- sconcat: only a 'TrueJoinPoint' if all are + -- | Doesn't return strictness marks idJoinPointHood :: Var -> JoinPointHood idJoinPointHood id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/678d8950191d2669134d4f126b96649… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/678d8950191d2669134d4f126b96649… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] deal with exitification
by sheaf (＠sheaf) 28 Jan '26

28 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: 593b8b96 by sheaf at 2026-01-27T18:44:58+01:00 deal with exitification - - - - - 4 changed files: - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Types/Id.hs Changes: ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -45,12 +45,14 @@ import GHC.Core.Type import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info +import GHC.Types.Tickish ( GenTickish(..), tickishCanScopeJoin ) + import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Basic( JoinPointHood(..) ) import GHC.Utils.Monad.State.Strict import GHC.Utils.Misc( mapSnd ) +import GHC.Utils.Outputable import GHC.Data.FastString @@ -93,23 +95,23 @@ exitifyProgram binds = map goTopLvl binds where in_scope' = in_scope `extendInScopeSet` bndr - go in_scope (Let (Rec pairs) body) - | is_join_rec = mkLets (exitifyRec in_scope' pairs') body' - | otherwise = Let (Rec pairs') body' + go in_scope (Let (Rec pairs) body) = + case joinPointType_maybe (joinId_maybe . fst) pairs of + Just join_ty -> mkLets (exitifyRec join_ty in_scope' pairs') body' + Nothing -> Let (Rec pairs') body' where - is_join_rec = any (isJoinId . fst) pairs in_scope' = in_scope `extendInScopeSetBind` (Rec pairs) pairs' = mapSnd (go in_scope') pairs body' = go in_scope' body -- | State Monad used inside `exitify` -type ExitifyM = State [(JoinId, CoreExpr)] +type ExitifyM = State [(JoinId, CoreExpr)] -- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as -- join-points outside the joinrec. -exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] -exitifyRec in_scope pairs +exitifyRec :: JoinPointType -> InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] +exitifyRec joinrec_join_ty in_scope pairs = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs'] where -- We need the set of free variables of many subexpressions here, so @@ -124,7 +126,7 @@ exitifyRec in_scope pairs forM ann_pairs $ \(x,rhs) -> do -- go past the lambdas of the join point let (args, body) = collectNAnnBndrs (idJoinArity x) rhs - body' <- go args body + body' <- go joinrec_join_ty args body -- (ExitJoin2): start with JoinPointType of parent joinrec let rhs' = mkLams args body' return (x, rhs') @@ -135,40 +137,41 @@ exitifyRec in_scope pairs -- variables bound on the way and lifts it out as a join point. -- -- ExitifyM is a state monad to keep track of floated binds - go :: [Var] -- Variables that are in-scope here, but - -- not in scope at the joinrec; that is, - -- we must potentially abstract over them. - -- Invariant: they are kept in dependency order + go :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points] + -> [Var] -- Variables that are in-scope here, but + -- not in scope at the joinrec; that is, + -- we must potentially abstract over them. + -- Invariant: they are kept in dependency order -> CoreExprWithFVs -- Current expression in tail position -> ExitifyM CoreExpr -- We first look at the expression (no matter what it shape is) -- and determine if we can turn it into a exit join point - go captured ann_e + go exit_join_ty captured ann_e | -- An exit expression has no recursive calls let fvs = dVarSetToVarSet (freeVarsOf ann_e) , disjointVarSet fvs recursive_calls - = go_exit captured (deAnnotate ann_e) fvs + = go_exit exit_join_ty captured (deAnnotate ann_e) fvs -- We could not turn it into a exit join point. So now recurse -- into all expression where eligible exit join points might sit, -- i.e. into all tail-call positions: -- Case right hand sides are in tail-call position - go captured (_, AnnCase scrut bndr ty alts) = do + go exit_join_ty captured (_, AnnCase scrut bndr ty alts) = do alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do - rhs' <- go (captured ++ [bndr] ++ pats) rhs + rhs' <- go exit_join_ty (captured ++ [bndr] ++ pats) rhs return (Alt dc pats rhs') return $ Case (deAnnotate scrut) bndr ty alts' - go captured (_, AnnLet ann_bind body) + go exit_join_ty captured (_, AnnLet ann_bind body) -- join point, RHS and body are in tail-call position | AnnNonRec j rhs <- ann_bind , JoinPoint { joinPointArity = join_arity } <- idJoinPointHood j = do let (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ params) join_body + join_body' <- go exit_join_ty (captured ++ params) join_body let rhs' = mkLams params join_body' - body' <- go (captured ++ [j]) body + body' <- go exit_join_ty (captured ++ [j]) body return $ Let (NonRec j rhs') body' -- rec join point, RHSs and body are in tail-call position @@ -178,30 +181,41 @@ exitifyRec in_scope pairs pairs' <- forM pairs $ \(j,rhs) -> do let join_arity = idJoinArity j (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ js ++ params) join_body + join_body' <- go exit_join_ty (captured ++ js ++ params) join_body let rhs' = mkLams params join_body' return (j, rhs') - body' <- go (captured ++ js) body + body' <- go exit_join_ty (captured ++ js) body return $ Let (Rec pairs') body' -- normal Let, only the body is in tail-call position | otherwise - = do body' <- go (captured ++ bindersOf bind ) body + = do body' <- go exit_join_ty (captured ++ bindersOf bind ) body return $ Let bind body' where bind = deAnnBind ann_bind + -- (ExitJoin1) from Note [Exitification and quasi join points] + go _ captured (_, AnnCast ann_e (_, co)) = do + e' <- go QuasiJoinPoint captured ann_e + return (Cast e' co) + go exit_join_ty captured (_, AnnTick tickish ann_e) + | tickishCanScopeJoin tickish + = Tick tickish <$> go exit_join_ty captured ann_e + | ProfNote {} <- tickish + = Tick tickish <$> go QuasiJoinPoint captured ann_e + -- Cannot be turned into an exit join point, but also has no -- tail-call subexpression. Nothing to do here. - go _ ann_e = return (deAnnotate ann_e) + go _ _ ann_e = return (deAnnotate ann_e) --------------------- - go_exit :: [Var] -- Variables captured locally + go_exit :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points] + -> [Var] -- Variables captured locally -> CoreExpr -- An exit expression -> VarSet -- Free vars of the expression -> ExitifyM CoreExpr -- go_exit deals with a tail expression that is floatable -- out as an exit point; that is, it mentions no recursive calls - go_exit captured e fvs + go_exit exit_join_ty captured e fvs -- Do not touch an expression that is already a join jump where all arguments -- are captured variables. See Note [Idempotency] -- But _do_ float join jumps with interesting arguments. @@ -226,7 +240,7 @@ exitifyRec in_scope pairs let rhs = mkLams abs_vars e avoid = in_scope `extendInScopeSetList` captured -- Remember this binding under a suitable name - ; v <- addExit avoid (length abs_vars) rhs + ; v <- addExit avoid exit_join_ty (length abs_vars) rhs -- And jump to it from here ; return $ mkVarApps (Var v) abs_vars } @@ -263,7 +277,7 @@ exitifyRec in_scope pairs -- * any bound variables (captured) -- * any exit join points created so far. mkExitJoinId :: InScopeSet -> Type -> JoinPointType -> JoinArity -> ExitifyM JoinId -mkExitJoinId in_scope ty join_ty join_arity = do +mkExitJoinId in_scope ty exit_join_ty join_arity = do fs <- get let avoid = in_scope `extendInScopeSetList` (map fst fs) `extendInScopeSet` exit_id_tmpl -- just cosmetics @@ -271,17 +285,65 @@ mkExitJoinId in_scope ty join_ty join_arity = do where exit_id_tmpl = asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty) - join_ty join_arity + exit_join_ty join_arity -addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_arity rhs = do +addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope exit_join_ty join_arity rhs = do -- Pick a suitable name let ty = exprType rhs - v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity + v <- mkExitJoinId in_scope ty exit_join_ty join_arity fs <- get put ((v,rhs):fs) return v +{- Note [Exitification and quasi join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an exit path, we must determine if the new exit join point +should be a true join point or a quasi join point, in the sense of +Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration). + +The new exit join point must be a quasi join point if either of the following +conditions apply. + + (ExitJoin1) The exit path occurs under a cast or a profiling tick. + + (ExitJoin2) The original joinrec was a quasi join point. + +Rationale for (ExitJoin1): + + Suppose we have: + + joinrec j x = ... case ... of alts -> e |> co ... in ... + + After exitifying 'e' to 'exit': + + join exit y = e in + joinrec j x = ... case ... of alts -> (exit y) |> co ... in ... + + Because the jump to 'exit' occurs under a cast, 'exit' must be classified + as a quasi join point. + +Rationale for (ExitJoin2): + + Suppose we have: + + quasijoinrec j x = case x of { 0 -> 100; _ -> j (x-1) } in j 0 |> co + + If we float an exit out of 'j', we end up with + + join exit = 100 in + quasijoinrec j x = case x of { 0 -> exit ; _ -> j (x-1) } in j 0 |> co + + Now suppose we inline j and simplify; we end up with: + + join exit = 100 in exit |> co + + We see now that 'exit' must be a quasi join point, due to the cast. + + Hence: exit join points for a parent quasi join point must themselves be + quasi join points. +-} + {- Note [Interesting expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) import Data.List (mapAccumL) -import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semi {- @@ -4118,10 +4117,7 @@ setBinderOcc occ_info bndr -- See Note [Invariants on join points] in "GHC.Core". decideRecJoinPointHood :: TopLevelFlag -> UsageDetails -> [CoreBndr] -> Maybe JoinPointType -decideRecJoinPointHood lvl usage bndrs = do - bndrsNE <- NE.nonEmpty bndrs - -- Invariant 3: Either all are join points or none are - Semi.sconcat <$> traverse ok bndrsNE +decideRecJoinPointHood lvl usage = joinPointType_maybe ok where ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2056,93 +2056,118 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont of a SpecConstr-generated RULE for a join point. -} --- SLD TODO horrible logic that must be removed -peelJoinResTy :: Int -> Type -> Type -peelJoinResTy 0 ty = ty -peelJoinResTy n ty - | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty - = peelJoinResTy n inner_ty - | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty - = peelJoinResTy (n-1) res_ty - | otherwise - = ty +joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type +joinResTy n0 ty0 = go n0 ty0 + where + go 0 ty = ty + go n ty + | Just (_bndr, res_ty) <- splitPiTy_maybe ty + = go (n-1) res_ty + | otherwise + = pprPanic "joinResTy" $ + vcat [ text "join arity:" <+> ppr n0 + , text "join ty:" <+> ppr ty0 + , text "n:" <+> ppr n + , text "ty:" <+> ppr ty + ] simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplNonRecJoinPoint env bndr rhs body cont +simplNonRecJoinPoint env0 bndr rhs body cont0 = assert (isJoinId bndr) $ - wrapJoinCont do_case_case env cont $ \ env cont -> + wrapJoinCont do_case_case env0 bndr cont0 $ + \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } -> do { -- We push join_cont into the join RHS and the body; -- and wrap wrap_cont around the whole thing - ; let (mult, res_ty) - -- SLD TODO - | Just QuasiJoinPoint <- joinId_maybe bndr - = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr)) - | otherwise - = (contHoleScaling cont, contResultType cont) + let mult = contHoleScaling bind_cont + res_ty = contResultType bind_cont ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) - ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) - ; (floats2, body') <- simplExprF env3 body cont + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont) + ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env) + ; (floats2, body') <- simplExprF env3 body body_cont ; return (floats1 `addFloats` floats2, body') } where do_case_case | Just TrueJoinPoint <- joinId_maybe bndr - = seCaseCase env + = seCaseCase env0 | otherwise = False simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplRecJoinPoint env pairs body cont - = wrapJoinCont do_case_case env cont $ \ env cont -> - do { let bndrs = map fst pairs - (mult, res_ty) - -- SLD TODO - | [b] <- bndrs - , Just QuasiJoinPoint <- joinId_maybe b - = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b)) - | otherwise - = (contHoleScaling cont, contResultType cont) +simplRecJoinPoint env0 pairs body cont0 + = wrapJoinCont do_case_case env0 (head bndrs) cont0 $ + \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } -> + do { let mult = contHoleScaling bind_cont + res_ty = contResultType bind_cont ; env1 <- simplRecJoinBndrs env bndrs mult res_ty -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs - ; (floats2, body') <- simplExprF env2 body cont + ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs + ; (floats2, body') <- simplExprF env2 body body_cont ; return (floats1 `addFloats` floats2, body') } where + bndrs = map fst pairs + do_case_case = - if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs - then seCaseCase env + if all ((== Just TrueJoinPoint) . joinId_maybe) bndrs + then seCaseCase env0 else False -------------------- + +-- | Information computed by 'wrapJoinCont'. +data WrapJoinCont + = WJC + { wjc_bind_env :: !SimplEnv + , wjc_bind_cont :: !SimplCont + , wjc_body_cont :: !SimplCont + } + wrapJoinCont :: Bool - -> SimplEnv -> SimplCont - -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplEnv -> InId -> SimplCont + -> (WrapJoinCont -> SimplM (SimplFloats, OutExpr)) -> SimplM (SimplFloats, OutExpr) -- Deal with making the continuation duplicable if necessary, -- and with the no-case-of-case situation. -wrapJoinCont do_case_case env cont thing_inside +wrapJoinCont do_case_case env join_bndr cont thing_inside | contIsStop cont -- Common case; no need for fancy footwork - = thing_inside env cont + = thing_inside $ + WJC { wjc_bind_env = env + , wjc_bind_cont = if do_case_case then cont else no_case_case_bind_cont + , wjc_body_cont = cont + } | do_case_case -- Normal situation: do the "case-of-case" transformation. -- See Note [Join points and case-of-case]. = do { (floats1, cont') <- mkDupableCont env cont - ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; let wjc = WJC { wjc_bind_env = env `setInScopeFromF` floats1 + , wjc_bind_cont = cont' + , wjc_body_cont = cont' + } + ; (floats2, result) <- thing_inside wjc ; return (floats1 `addFloats` floats2, result) } | otherwise -- No "case-of-case" transformation. -- See Note [Join points with -fno-case-of-case]. - = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + = do { let + wjc = WJC { wjc_bind_env = env + , wjc_bind_cont = no_case_case_bind_cont + , wjc_body_cont = mkBoringStop (contHoleType cont) + } + ; (floats1, expr1) <- thing_inside wjc ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont ; return (floats2 `addFloats` floats3, expr3) } + where + -- See Wrinkle [Casts and join point result types] + join_res_ty = joinResTy (idJoinArity join_bndr) + $ substTy env (idType join_bndr) + no_case_case_bind_cont = mkBoringStop join_res_ty -------------------- trimJoinCont :: Id -- Used only in error message @@ -2282,9 +2307,9 @@ As per Note [Join points and case-of-case], we proceed by first applying the argument to both the join point RHS and the case alternatives: join { j :: Bool -> IO (); j _ = guts arg ] } - in case b of - False -> (scctick<foo> jump j True) arg - True -> jump j False arg + in case b of + False -> (scctick<foo> jump j True) arg + True -> jump j False arg Then we rely on 'trimJoinCont' to remove the argument. In this case, this fails for the first branch, because 'trimJoinCont' doesn't look through profiling @@ -2293,9 +2318,9 @@ end up with, as we don't want to misattribute profiling costs. We could plausibly transform to the following: join { j :: Bool -> IO (); j scc_or_null _ = (setSCC# scc_or_null guts) arg ] } - in case b of - False -> jump j <foo> True - True -> jump j null False + in case b of + False -> jump j <foo> True + True -> jump j null False where `setSCC#` is a new primop that would set the current cost centre pointer (or no-op if the given pointer is null). @@ -2307,17 +2332,17 @@ So instead, for now, we simply disallow the case-of-case transformation for 'j'. Similarly for casts: join { j = blah } - in case e of - False -> j True |> co1 - True -> j False |> co2 + in case e of + False -> j True |> co1 + True -> j False |> co2 if we want to apply this to an argument 'arg', we would need to perform the following transformation: join { j co = ( blah |> co ) arg } - in case e of - False -> j co1 True - True -> j co2 False + in case e of + False -> j co1 True + True -> j co2 False in which we add a coercion argument to the join point. Again, this is not a transformation we currently implement, so we instead prevent case-of-case for @@ -2339,6 +2364,33 @@ we proceed as follows: If we are dealing with a quasi join point, we switch off the case-of-case transformation. +Wrinkle [Casts and join point result types] + + When dealing with a quasi joint-point, we must preserve the original type of + the join point instead of transforming the type (as in Core.Opt.Simplify.Env.adjustJoinPointType). + This is because we don't trim the continuation like we do in + Note [Join points and case-of-case]. + + For example, suppose we have: + + type family F a + + join + j :: forall a. a -> F a + j @a x = ... + in case e of + False -> j @T1 x1 |> ( co1 :: F T1 ~ Int ) + True -> j @T2 x2 |> ( co2 :: F T2 ~ Int ) + + If we used 'contHoleType cont' to compute the result type of 'j', we would + change the result type of 'j' to 'Int', when it needs to remain 'F a'. + + Instead, we avoid doing that and re-compute the result type of 'j' using + 'joinResTy' to get 'F a', as required. + +See also Note [Exitification and quasi join points] in GHC.Core.Opt.Exitify +for another wrinkle. + ************************************************************************ * * Variables ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -79,7 +79,8 @@ module GHC.Types.Id ( -- ** Join variables JoinId, JoinPointHood, - isJoinId, joinId_maybe, idJoinPointHood, idJoinArity, + isJoinId, joinId_maybe, joinPointType_maybe, + idJoinPointHood, idJoinArity, asJoinId, asJoinId_maybe, zapJoinId, -- ** Inline pragma stuff @@ -172,6 +173,8 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as Semi -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, @@ -584,6 +587,13 @@ joinId_maybe id _ -> Nothing | otherwise = Nothing +joinPointType_maybe :: (a -> Maybe JoinPointType) -> [a] -> Maybe JoinPointType +joinPointType_maybe f xs = do + xsNE <- NE.nonEmpty xs + Semi.sconcat <$> traverse f xsNE + -- traverse: either all are join points or none are + -- sconcat: only a 'TrueJoinPoint' if all are + -- | Doesn't return strictness marks idJoinPointHood :: Var -> JoinPointHood idJoinPointHood id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/593b8b964a2783934499bd81d625e4d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/593b8b964a2783934499bd81d625e4d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/submodule-bumps-2026-01
by Cheng Shao (＠TerrorJack) 28 Jan '26

28 Jan '26

Cheng Shao pushed new branch wip/submodule-bumps-2026-01 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/submodule-bumps-2026-01 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: Add operations for obtaining operating-system handles
by Marge Bot (＠marge-bot) 28 Jan '26

28 Jan '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 5957a8ad by Wolfgang Jeltsch at 2026-01-27T06:11:40-05:00 Add operations for obtaining operating-system handles This contribution implements CLC proposal #369. It adds operations for obtaining POSIX file descriptors and Windows handles that underlie Haskell handles. Those operating system handles can also be obtained without such additional operations, but this is more involved and, more importantly, requires using internals. - - - - - 86a0510c by Greg Steuck at 2026-01-27T06:12:34-05:00 Move flags to precede patterns for grep and read files directly This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools. There's no reason to use cat and pipe where direct file argument works. - - - - - eeabc098 by Cheng Shao at 2026-01-27T12:20:33-05:00 ci: update darwin boot ghc to 9.10.3 This patch updates darwin boot ghc to 9.10.3, along with other related updates, and pays off some technical debt here: - Update `nixpkgs` and use the `nixpkgs-25.05-darwin` channel. - Update the `niv` template. - Update LLVM to 21 and update `llvm-targets` to reflect LLVM 21 layout changes for arm64/x86_64 darwin targets. - Use `stdenvNoCC` to prevent nix packaged apple sdk from being used by boot ghc, and manually set `DEVELOPER_DIR`/`SDKROOT` to enforce the usage of system-wide command line sdk for macos. - When building nix derivation for boot ghc, run `configure` via the `arch` command so that `configure` and its subprocesses pick up the manually specified architecture. - Remove the previous horrible hack that obliterates `configure` to make autoconf test result in true. `configure` now properly does its job. - Remove the now obsolete configure args and post install settings file patching logic. - Use `scheme-small` for texlive to avoid build failures in certain unused texlive packages, especially on x86_64-darwin. - - - - - 7a6d9d44 by Matthew Pickering at 2026-01-27T12:20:34-05:00 Evaluate backtraces for "error" exceptions at the moment they are thrown See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] which explain the implementation. This commit makes `error` and `throw` behave the same with regard to backtraces. Previously, exceptions raised by `error` would not contain useful IPE backtraces. I did try and implement `error` in terms of `throw` but it started to involve putting diverging functions into hs-boot files, which seemed to risky if the compiler wouldn't be able to see if applying a function would diverge. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383 Fixes #26751 - - - - - 1516e93a by Teo Camarasu at 2026-01-27T12:20:35-05:00 ghc-internal: move all Data instances to Data.Data Most instances of Data are defined in GHC.Internal.Data.Data. Let's move all remaining instance there. This moves other modules down in the dependency hierarchy allowing for more parallelism, and it decreases the likelihood that we would need to load this heavy .hi file if we don't actually need it. Resolves #26830 Metric Decrease: T12227 T16875 - - - - - 41 changed files: - .gitlab/darwin/nix/sources.json - .gitlab/darwin/toolchain.nix - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/System/IO/OS.hs - libraries/base/tests/IO/all.T - + libraries/base/tests/IO/osHandles001FileDescriptors.hs - + libraries/base/tests/IO/osHandles001FileDescriptors.stdout - + libraries/base/tests/IO/osHandles001WindowsHandles.hs - + libraries/base/tests/IO/osHandles001WindowsHandles.stdout - + libraries/base/tests/IO/osHandles002FileDescriptors.hs - + libraries/base/tests/IO/osHandles002FileDescriptors.stderr - + libraries/base/tests/IO/osHandles002FileDescriptors.stdin - + libraries/base/tests/IO/osHandles002FileDescriptors.stdout - + libraries/base/tests/IO/osHandles002WindowsHandles.hs - + libraries/base/tests/IO/osHandles002WindowsHandles.stderr - + libraries/base/tests/IO/osHandles002WindowsHandles.stdin - + libraries/base/tests/IO/osHandles002WindowsHandles.stdout - libraries/base/tests/perf/Makefile - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs - + libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/tests/stack-annotation/all.T - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - llvm-targets - testsuite/tests/driver/T16318/Makefile - testsuite/tests/driver/T18125/Makefile - testsuite/tests/ghci.debugger/scripts/T8487.stdout - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break017.stdout - testsuite/tests/ghci.debugger/scripts/break025.stdout - 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/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bce2a8faf0531ef6367d783bd316dc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bce2a8faf0531ef6367d783bd316dc… You're receiving this email because of your account on gitlab.haskell.org.

1 0