- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/fendor/hpc-bc-support] 2 commits: Make HPC work with bytecode interpreter
by Hannes Siebenhandl (＠fendor) 13 Apr '26

13 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: cfb22c59 by fendor at 2026-04-13T12:15:43+02:00 Make HPC work with bytecode interpreter Add support to generate .tix files from bytecode objects and the bytecode interpreter. Conceptually, we insert HPC ticks into the bytecode similar to how we insert breakpoints. HPC and breakpoints do not share the same tick array but we use a separate tick-array for hpc/breakpoint ticks during bytecode generation. We teach the bytecode interpreter to handle hpc ticks. The implementation is quite trivial, simply increment the counter in the global hpc_ticks array for the respective module. This hpc_ticks array is generated as part of the `CStub`, so we can rely on it existing. A tricky bit is "registering" a bytecode object for HPC instrumentation. In the compiled case, this is achieved via CStub and initializer/finalizers `.init` sections which are called when the executable is run. After the initializers have been invoked, which is before `hs_init_ghc`, we then call `startup_hpc` in `hs_init_ghc` iff any modules were "registered" for hpc instrumentation via `hs_hpc_module`. Since bytecode objects are loaded after starting up GHCi, this workflow doesn't work for supporting `hpc` and the `hpc` run-time is never started, even if a module is added for instrumentation. We fix this issue by employing the same technique as is for `SptEntry`s: * We introduce a new field to `CompiledByteCode`, called `ByteCodeHpcInfo` which contains enough information to call `hs_hpc_module`, allowing us to register the module for `hpc` instrumentation`. * After registering the module, we unconditionally call `startupHpc`, to make sure the .tix file is written. Calling `startupHpc` multiple times is safe. Calling `hs_hpc_module` multiple times for the same module is also safe. If we didn't register the hpc module in this way, evaluating a bytecode object instrumented with `-fhpc` without registering it in the `hpc` run-time will simply not generate any `.tix` files for this bytecode object. However, this shouldn't happen if everything is set up correctly. Closes #27036 - - - - - d9e7c293 by fendor at 2026-04-13T12:15:43+02:00 Use common module name printing function - - - - - 52 changed files: - + changelog.d/bytecode-interpreter-hpc-support - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Coverage.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/HpcInfo.hs - compiler/GHC/Unit/Module/ModGuts.hs - + libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Disassembler.c - rts/Hpc.c - rts/Interpreter.c - rts/include/rts/Bytecodes.h - testsuite/tests/hpc/Makefile - testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout - + testsuite/tests/hpc/T17073b.stdout - testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout - + testsuite/tests/hpc/T20568b.stdout - testsuite/tests/hpc/all.T - testsuite/tests/hpc/fork/Makefile - testsuite/tests/hpc/function/Makefile - testsuite/tests/hpc/function/test.T - + testsuite/tests/hpc/function/tough1.stderr - + testsuite/tests/hpc/function/tough1.stdout - testsuite/tests/hpc/function2/test.T - + testsuite/tests/hpc/function2/tough3.script - + testsuite/tests/hpc/ghc_ghci/BytecodeMain.hs - testsuite/tests/hpc/ghc_ghci/Makefile - + testsuite/tests/hpc/ghc_ghci/hpc_ghc_ghci_bytecode.stdout - testsuite/tests/hpc/ghc_ghci/test.T - testsuite/tests/hpc/hpcrun.pl - testsuite/tests/hpc/simple/Makefile - + testsuite/tests/hpc/simple/hpc002.hs - + testsuite/tests/hpc/simple/hpc002.stdout - + testsuite/tests/hpc/simple/hpc003.hs - + testsuite/tests/hpc/simple/hpc003.script - + testsuite/tests/hpc/simple/hpc003.stderr - + testsuite/tests/hpc/simple/hpc003.stdout - testsuite/tests/hpc/simple/test.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7883e5f16b610f076c55fa6bd7f265… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7883e5f16b610f076c55fa6bd7f265… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/27162/hadrian-linkhs-response-file] Use response files for hadrian linking with ghc (support long command lines)
by David Eichmann (＠DavidEichmann) 13 Apr '26

13 Apr '26

David Eichmann pushed to branch wip/27162/hadrian-linkhs-response-file at Glasgow Haskell Compiler / GHC Commits: 5bc20af3 by Duncan Coutts at 2026-04-13T10:48:09+01:00 Use response files for hadrian linking with ghc (support long command lines) In future supoort for windows dynamic linking, we expect long command lines for linking dll files with ghc. Experiments with dynamic linking the ghc-internal library yielded a link command well over 32kb. We did not encounter this before for static libs, since we already use ar's @file feature (if available, which it is for the llvm toolchain). Co-authored-by: David Eichmann <davide(a)well-typed.com> - - - - - 1 changed file: - hadrian/src/Builder.hs Changes: ===================================== hadrian/src/Builder.hs ===================================== @@ -345,12 +345,16 @@ instance H.Builder Builder where Haddock BuildPackage -> runHaddock path buildArgs buildInputs - Ghc FindHsDependencies _ -> do - -- Use a response file for ghc -M invocations, to - -- avoid issues with command line size limit on - -- Windows (#26637) + Ghc FindHsDependencies _ -> + -- We can't put the flags in a response file, because some flags + -- require empty arguments (such as the -dep-suffix flag), but + -- that isn't supported yet due to #26560. runGhcWithResponse path buildArgs buildInputs + Ghc LinkHs _ -> + -- We do not pass `buildInputs` as they are duplicated in `buildArgs` + runGhcWithResponse path [] buildArgs + HsCpp -> captureStdout Make dir -> cmd' buildOptions path ["-C", dir] buildArgs @@ -393,15 +397,33 @@ runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do writeFile' tmp $ escapeArgs fileInputs cmd [haddockPath] flagArgs ('@' : tmp) -runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action () -runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do - - writeFile' tmp $ escapeArgs fileInputs - - -- We can't put the flags in a response file, because some flags - -- require empty arguments (such as the -dep-suffix flag), but - -- that isn't supported yet due to #26560. - cmd [ghcPath] flagArgs ('@' : tmp) +-- | Use a response file for ghc invocations to avoid issues with command line +-- size limit on Windows (#26637). +runGhcWithResponse :: FilePath -- ^ Path to ghc + -> [String] -- ^ Arguments passed on the command line + -> [String] -- ^ Arguments passed via the response file (cannot contain empty arguemnts) + -> Action () +runGhcWithResponse ghcPath args responseFileArgs = withTempFile $ \tmp -> do + -- RTS options are not supported in response files, so the are extracted here. + -- Returns (ghc args, rts args) + let splitRtsArgs inRtsSection argsRest = case argsRest of + [] -> ([], []) + "--RTS":rest -> (rest, []) + "-RTS":rest -> splitRtsArgs False rest + "+RTS":rest -> splitRtsArgs True rest + arg:rest -> + let (restGhc, restRts) = splitRtsArgs inRtsSection rest + in if inRtsSection + then (restGhc, arg:restRts) + else (arg:restGhc, restRts) + (responseFileArgsGhc, argsRts) = splitRtsArgs False responseFileArgs + tmpContents = escapeArgs responseFileArgsGhc + when + (any null responseFileArgsGhc) + (putWarn $ "Response file arguments (" <> tmp <> ") contains empty arguments") + putVerbose $ tmp <> ": " <> tmpContents + writeFile' tmp tmpContents + cmd [ghcPath] ("+RTS" : argsRts ++ ["-RTS"] ++ args) ('@' : tmp) -- TODO: Some builders are required only on certain platforms. For example, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bc20af36c45b0d8e1f23107188a476… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bc20af36c45b0d8e1f23107188a476… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/27162/hadrian-linkhs-response-file] Use response files for hadrian linking with ghc.
by David Eichmann (＠DavidEichmann) 13 Apr '26

13 Apr '26

David Eichmann pushed to branch wip/27162/hadrian-linkhs-response-file at Glasgow Haskell Compiler / GHC Commits: 04404a2a by Duncan Coutts at 2026-04-13T10:47:05+01:00 Use response files for hadrian linking with ghc. In future supoort for windows dynamic linking, we expect long command lines for linking dll files (which use ghc calling (l)ld) rather than ar as is done for static linking). Experiments yielded a link command line for ghc-internal well over 32kb. We did not encounter this before for static libs, since we already use ar's @file feature (if available, which it is for the llvm toolchain). Co-authored-by: David Eichmann <davide(a)well-typed.com> - - - - - 1 changed file: - hadrian/src/Builder.hs Changes: ===================================== hadrian/src/Builder.hs ===================================== @@ -345,12 +345,16 @@ instance H.Builder Builder where Haddock BuildPackage -> runHaddock path buildArgs buildInputs - Ghc FindHsDependencies _ -> do - -- Use a response file for ghc -M invocations, to - -- avoid issues with command line size limit on - -- Windows (#26637) + Ghc FindHsDependencies _ -> + -- We can't put the flags in a response file, because some flags + -- require empty arguments (such as the -dep-suffix flag), but + -- that isn't supported yet due to #26560. runGhcWithResponse path buildArgs buildInputs + Ghc LinkHs _ -> + -- We do not pass `buildInputs` as they are duplicated in `buildArgs` + runGhcWithResponse path [] buildArgs + HsCpp -> captureStdout Make dir -> cmd' buildOptions path ["-C", dir] buildArgs @@ -393,15 +397,33 @@ runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do writeFile' tmp $ escapeArgs fileInputs cmd [haddockPath] flagArgs ('@' : tmp) -runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action () -runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do - - writeFile' tmp $ escapeArgs fileInputs - - -- We can't put the flags in a response file, because some flags - -- require empty arguments (such as the -dep-suffix flag), but - -- that isn't supported yet due to #26560. - cmd [ghcPath] flagArgs ('@' : tmp) +-- | Use a response file for ghc invocations to avoid issues with command line +-- size limit on Windows (#26637). +runGhcWithResponse :: FilePath -- ^ Path to ghc + -> [String] -- ^ Arguments passed on the command line + -> [String] -- ^ Arguments passed via the response file (cannot contain empty arguemnts) + -> Action () +runGhcWithResponse ghcPath args responseFileArgs = withTempFile $ \tmp -> do + -- RTS options are not supported in response files, so the are extracted here. + -- Returns (ghc args, rts args) + let splitRtsArgs inRtsSection argsRest = case argsRest of + [] -> ([], []) + "--RTS":rest -> (rest, []) + "-RTS":rest -> splitRtsArgs False rest + "+RTS":rest -> splitRtsArgs True rest + arg:rest -> + let (restGhc, restRts) = splitRtsArgs inRtsSection rest + in if inRtsSection + then (restGhc, arg:restRts) + else (arg:restGhc, restRts) + (responseFileArgsGhc, argsRts) = splitRtsArgs False responseFileArgs + tmpContents = escapeArgs responseFileArgsGhc + when + (any null responseFileArgsGhc) + (putWarn $ "Response file arguments (" <> tmp <> ") contains empty arguments") + putVerbose $ tmp <> ": " <> tmpContents + writeFile' tmp tmpContents + cmd [ghcPath] ("+RTS" : argsRts ++ ["-RTS"] ++ args) ('@' : tmp) -- TODO: Some builders are required only on certain platforms. For example, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04404a2a0d49c7caa8087d28741e608… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04404a2a0d49c7caa8087d28741e608… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/27162/hadrian-linkhs-response-file] Use response files for hadrian linking with ghc.
by David Eichmann (＠DavidEichmann) 13 Apr '26

13 Apr '26

David Eichmann pushed to branch wip/27162/hadrian-linkhs-response-file at Glasgow Haskell Compiler / GHC Commits: e51ca131 by Duncan Coutts at 2026-04-13T10:40:35+01:00 Use response files for hadrian linking with ghc. In future supoort for windows dynamic linking, we expect long command lines for linking dll files (which use ghc calling (l)ld) rather than ar as is done for static linking). Experiments yielded a link command line for ghc-internal well over 32kb. We did not encounter this before for static libs, since we already use ar's @file feature (if available, which it is for the llvm toolchain). Co-authored-by: David Eichmann <davide(a)well-typed.com> - - - - - 1 changed file: - hadrian/src/Builder.hs Changes: ===================================== hadrian/src/Builder.hs ===================================== @@ -345,12 +345,16 @@ instance H.Builder Builder where Haddock BuildPackage -> runHaddock path buildArgs buildInputs - Ghc FindHsDependencies _ -> do - -- Use a response file for ghc -M invocations, to - -- avoid issues with command line size limit on - -- Windows (#26637) + Ghc FindHsDependencies _ -> + -- We can't put the flags in a response file, because some flags + -- require empty arguments (such as the -dep-suffix flag), but + -- that isn't supported yet due to #26560. runGhcWithResponse path buildArgs buildInputs + Ghc LinkHs _ -> + -- We do not pass `buildInputs` as they are duplicated in `buildArgs` + runGhcWithResponse path [] buildArgs + HsCpp -> captureStdout Make dir -> cmd' buildOptions path ["-C", dir] buildArgs @@ -393,15 +397,31 @@ runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do writeFile' tmp $ escapeArgs fileInputs cmd [haddockPath] flagArgs ('@' : tmp) -runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action () -runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do - - writeFile' tmp $ escapeArgs fileInputs - - -- We can't put the flags in a response file, because some flags - -- require empty arguments (such as the -dep-suffix flag), but - -- that isn't supported yet due to #26560. - cmd [ghcPath] flagArgs ('@' : tmp) +-- | Use a response file for ghc invocations to avoid issues with command line +-- size limit on Windows (#26637). +runGhcWithResponse :: FilePath -- ^ Path to ghc + -> [String] -- ^ Arguments passed on the command line + -> [String] -- ^ Arguments passed via the response file (cannot contain empty arguemnts) + -> Action () +runGhcWithResponse ghcPath args responseFileArgs = withTempFile $ \tmp -> do + -- Extract RTS options from reponseFileArgs. Returns (ghc args, rts args) + let splitRtsArgs inRtsSection argsRest = case argsRest of + [] -> ([], []) + "--RTS":rest -> (rest, []) + "-RTS":rest -> splitRtsArgs False rest + "+RTS":rest -> splitRtsArgs True rest + arg:rest -> let (restGhc, restRts) = splitRtsArgs inRtsSection rest + in if inRtsSection + then (restGhc, arg:restRts) + else (arg:restGhc, restRts) + (responseFileArgsGhc, argsRts) = splitRtsArgs False responseFileArgs + tmpContents = escapeArgs responseFileArgsGhc + when + (any null responseFileArgsGhc) + (putWarn $ "Response file arguments (" <> tmp <> ") contains empty arguments") + putVerbose $ tmp <> ": " <> tmpContents + writeFile' tmp tmpContents + cmd [ghcPath] ("+RTS" : argsRts ++ ["-RTS"] ++ args) ('@' : tmp) -- TODO: Some builders are required only on certain platforms. For example, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e51ca131520d0bb0d7efed266d82ea7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e51ca131520d0bb0d7efed266d82ea7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: tc: discard warnings in tcUserStmt Plan C
by Marge Bot (＠marge-bot) 13 Apr '26

13 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 585d7450 by Luite Stegeman at 2026-04-11T02:17:13-04:00 tc: discard warnings in tcUserStmt Plan C We typecheck let_stmt twice, but we don't want the warnings twice! see #26233 - - - - - 2df604e9 by Sylvain Henry at 2026-04-11T02:19:30-04:00 Introduce TargetInt to represent target's Int (#15973) GHC was using host 'Int' in several places to represent values that live in the target machine's 'Int' type. This is silently wrong when cross-compiling from a 32-bit host to a 64-bit target: the host Int is 32 bits while the target Int is 64 bits. See Note [TargetInt] in GHC.Platform. Also used the opportunity to make DynTag = Word8. Fixes #15973 Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 15b335ac by Luite Stegeman at 2026-04-13T05:19:21-04:00 Suppress desugaring warnings in the pattern match checker Avoid duplicating warnings from the actual desugaring pass. fixes #25996 - - - - - 8501dce1 by Phil de Joux at 2026-04-13T05:19:31-04:00 Typo ~/ghc/arch-os-version/environments - - - - - 29 changed files: - + changelog.d/fix-duplicate-pmc-warnings - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/Cmm/LayoutStack.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/Platform.hs - compiler/GHC/Platform/Tag.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Heap.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Prof.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/Tc/Module.hs - docs/users_guide/packages.rst - + testsuite/tests/deSugar/should_compile/T25996.hs - + testsuite/tests/deSugar/should_compile/T25996.stderr - testsuite/tests/deSugar/should_compile/all.T - + testsuite/tests/ghci/scripts/T26233.script - + testsuite/tests/ghci/scripts/T26233.stderr - + testsuite/tests/ghci/scripts/T26233.stdout - testsuite/tests/ghci/scripts/all.T Changes: ===================================== changelog.d/fix-duplicate-pmc-warnings ===================================== @@ -0,0 +1,6 @@ +section: compiler +synopsis: Fix duplicate desugaring warnings emitted by the pattern match checker. + The pattern match checker now suppresses warnings that are already reported + by the main desugaring pass. +issues: #25996 +mrs: !15859 ===================================== compiler/GHC/ByteCode/InfoTable.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Core.TyCon ( TyCon, tyConFamilySize, isBoxedDataTyCon, tyConDat import GHC.Core.Multiplicity ( scaledThing ) import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) -import GHC.StgToCmm.Closure ( tagForCon ) +import GHC.StgToCmm.Closure ( tagForCon, fromDynTag ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -58,7 +58,7 @@ make_constr_itbls profile cons = ptrs' nptrs_really conNo - (tagForCon platform dcon) + (fromDynTag (tagForCon platform dcon)) descr ) where ===================================== compiler/GHC/Cmm/LayoutStack.hs ===================================== @@ -927,7 +927,7 @@ areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n) -- Replace (CmmStackSlot area n) with an offset from Sp areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark) - = mkIntExpr platform sp_hwm + = mkIntExpr platform (toTargetInt sp_hwm) -- Replace CmmHighStackMark with the number of bytes of stack used, -- the sp_hwm. See Note [Stack usage] in GHC.StgToCmm.Heap @@ -1199,7 +1199,7 @@ lowerSafeForeignCall profile block callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O callSuspendThread platform id intrbl = CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) - [id] [baseExpr platform, mkIntExpr platform (fromEnum intrbl)] + [id] [baseExpr platform, mkIntExpr platform (toTargetInt (fromEnum intrbl))] callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id = ===================================== compiler/GHC/Cmm/Utils.hs ===================================== @@ -162,12 +162,16 @@ typeForeignHint = primRepForeignHint . typePrimRepU -- --------------------------------------------------- --- XXX: should really be Integer, since Int doesn't necessarily cover --- the full range of target Ints. -mkIntCLit :: Platform -> Int -> CmmLit +-- | Make a word-width 'CmmLit' for a target 'Int' value. +-- Uses 'TargetInt' (= 'Int64') rather than host 'Int' to avoid +-- truncation when cross-compiling from a 32-bit host to a 64-bit target. +-- See Note [TargetInt] in GHC.Platform. +mkIntCLit :: Platform -> TargetInt -> CmmLit mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform) -mkIntExpr :: Platform -> Int -> CmmExpr +-- | Make a word-width 'CmmExpr' for a target 'Int' value. +-- See Note [TargetInt] in GHC.Platform. +mkIntExpr :: Platform -> TargetInt -> CmmExpr mkIntExpr platform i = CmmLit $! mkIntCLit platform i zeroCLit :: Platform -> CmmLit @@ -279,7 +283,7 @@ cmmIndexExpr platform width base idx = cmmOffsetExpr platform base byte_off where idx_w = cmmExprWidth platform idx - byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)] + byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (toTargetInt (widthInLog width))] cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr cmmLoadIndex platform ty expr ix = ===================================== compiler/GHC/HsToCore/Pmc/Desugar.hs ===================================== @@ -375,16 +375,18 @@ desugarConPatOut x con univ_tys ex_tvs dicts = \case desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre) -- See 'GrdPatBind' for how this simply repurposes GrdGRHS. -desugarPatBind loc var pat = +-- See Note [Suppress warnings in PMC desugaring] +desugarPatBind loc var pat = discardWarningsDs $ PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarPat var pat desugarEmptyCase :: Id -> DsM PmEmptyCase desugarEmptyCase var = pure PmEmptyCase { pe_var = var } -- | Desugar the non-empty 'Match'es of a 'MatchGroup'. +-- See Note [Suppress warnings in PMC desugaring] desugarMatches :: [Id] -> NonEmpty (LMatch GhcTc (LHsExpr GhcTc)) -> DsM (PmMatchGroup Pre) -desugarMatches vars matches = +desugarMatches vars matches = discardWarningsDs $ PmMatchGroup <$> traverse (desugarMatch vars) matches -- Desugar a single match @@ -398,8 +400,9 @@ desugarMatch vars (L match_loc (Match { m_pats = L _ pats, m_grhss = grhss })) = -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss']) return PmMatch { pm_pats = pats', pm_grhss = grhss' } +-- See Note [Suppress warnings in PMC desugaring] desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre) -desugarGRHSs match_loc pp_pats grhss = do +desugarGRHSs match_loc pp_pats grhss = discardWarningsDs $ do lcls <- desugarLocalBinds (grhssLocalBinds grhss) grhss' <- traverse (desugarLGRHS match_loc pp_pats) (grhssGRHSs grhss) return PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss' } @@ -593,6 +596,17 @@ The place to store the 'PmLet' guards for @where@ clauses (which are per 'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of @x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'. +Note [Suppress warnings in PMC desugaring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module uses 'dsLExpr', 'dsExpr', and 'dsSyntaxExpr' to desugar +expressions into Core for pattern match checking. The main desugaring +pass in GHC.HsToCore processes these same expressions too, so without +suppression any warnings would be emitted twice (#25996). + +To avoid this, the exported functions ('desugarPatBind', 'desugarMatches', +'desugarGRHSs') are wrapped in 'discardWarningsDs', covering all internal +desugarer calls without having to wrap each one individually. + Note [Desugaring -XStrict matches in Pmc] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#21761) ===================================== compiler/GHC/Platform.hs ===================================== @@ -44,6 +44,9 @@ module GHC.Platform , platformHsSOName , platformSOExt , genericPlatform + -- * Target integer type + , TargetInt + , toTargetInt ) where @@ -61,6 +64,25 @@ import Data.Int import System.FilePath import System.Directory +-- Note [TargetInt] +-- ~~~~~~~~~~~~~~~~ +-- GHC uses 'TargetInt' to represent a value of type 'Int' on the target +-- machine. This is distinct from the host's 'Int' type: when cross-compiling +-- from a 32-bit host to a 64-bit target, the host 'Int' is 32 bits but the +-- target's 'Int' type is 64 bits. Using host 'Int' to store target 'Int' +-- values would cause silent truncation in that scenario. +-- +-- We use 'Int64' because it covers the full range of any supported target +-- (32-bit or 64-bit), while still being a fixed-size type that participates in +-- correct signed arithmetic (e.g. bitwise complement, see 'cmmPointerMask'). +type TargetInt = Int64 + +-- | Convert a host-side 'Int' value to a 'TargetInt'. +-- Use this when converting host-computed counts or offsets into target-sized +-- integers, e.g. when passing to 'mkIntExpr' or 'mkIntCLit'. +toTargetInt :: Int -> TargetInt +toTargetInt = fromIntegral + -- | Platform description -- -- This is used to describe platforms so that we can generate code for them. ===================================== compiler/GHC/Platform/Tag.hs ===================================== @@ -6,14 +6,24 @@ module GHC.Platform.Tag , tAG_MASK , mAX_PTR_TAG , isSmallFamily + , toDynTag + , fromDynTag ) where import GHC.Prelude import GHC.Platform +import GHC.Utils.Panic.Plain (assert) --- | The tag on a pointer (from the dynamic-tagging paper) -type DynTag = Int +import Data.Word (Word8) + +-- | The tag on a pointer (from the dynamic-tagging paper). +-- Wraps a 'Word8' because pointer tags are non-negative and bounded by the +-- number of tag bits on the platform (2 or 3 bits in practice), so values +-- never exceed 7. Use 'toDynTag' to construct, 'fromDynTag' to extract. +-- See Note [Data constructor dynamic tags]. +newtype DynTag = DynTag Word8 + deriving (Eq, Ord, Show) {- Note [Data constructor dynamic tags] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -35,13 +45,37 @@ The interpreter also needs to be updated if we change the tagging strategy; see tagConstr in rts/Interpreter.c. -} --- | Tag bits mask / maximum pointer tag value, derived from the --- number of tag bits on the platform. -tAG_MASK, mAX_PTR_TAG :: Platform -> Int +-- | Word-sized bitmask of the tag bits (all tag bits set to 1). +-- Used in bitwise operations such as 'cmmTagMask' and 'cmmPointerMask'. +-- This is a 'TargetInt' because it participates in word-width arithmetic +-- on the target (see Note [TargetInt] in GHC.Platform). +tAG_MASK :: Platform -> TargetInt tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1 -mAX_PTR_TAG = tAG_MASK + +-- | Maximum pointer tag value; equivalently the number of tag bits set. +-- This is the 'DynTag' companion to 'tAG_MASK': small enough to fit in +-- 'Word8' since it equals tAG_MASK but is used as a tag number, not a mask. +mAX_PTR_TAG :: Platform -> DynTag +mAX_PTR_TAG platform = DynTag (fromIntegral (tAG_MASK platform)) + +-- | Narrow a host-side 'Int' to a 'DynTag', asserting that the value is +-- non-negative and does not exceed 'mAX_PTR_TAG' for the given platform. +toDynTag :: Platform -> Int -> DynTag +toDynTag platform n = + assert (n >= 0 && n <= fromDynTag (mAX_PTR_TAG platform)) $ + DynTag (fromIntegral n) + +-- | Unwrap a 'DynTag' to a host-side 'Int'. +-- Safe because 'DynTag' values are always small: at most 'mAX_PTR_TAG', +-- bounded by the number of tag bits on the platform (typically 2 or 3 bits, +-- so at most 7). +fromDynTag :: DynTag -> Int +fromDynTag (DynTag w) = fromIntegral w -- | Is a data type family small enough that each constructor can get -- its own pointer tag? +-- +-- 'fam_size' is a host-side constructor count; compare against +-- 'mAX_PTR_TAG' via 'fromDynTag' to stay in 'Int' arithmetic. isSmallFamily :: Platform -> Int -> Bool -isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform +isSmallFamily platform fam_size = fam_size <= fromDynTag (mAX_PTR_TAG platform) ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -303,7 +303,7 @@ cgEnumerationTyCon tycon = do platform <- getPlatform emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs) - (tagForCon platform con) + (fromDynTag (tagForCon platform con)) | con <- tyConDataCons tycon] cgDataCon :: ConInfoTableLocation -> DataCon -> FCode () @@ -342,7 +342,7 @@ cgDataCon mn data_con ; let node = CmmReg $ nodeReg platform ; ldvEnter node ; tickyReturnOldCon (length arg_reps) - ; void $ emitReturn [cmmOffsetB platform node (tagForCon platform data_con)] + ; void $ emitReturn [cmmOffsetB platform node (fromDynTag (tagForCon platform data_con))] } -- The case continuation code expects a tagged pointer } ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -589,7 +589,7 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details ; enterCostCentreFun cc (CmmMachOp (mo_wordSub platform) [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] - , mkIntExpr platform (funTag platform cl_info) ]) + , mkIntExpr platform (toTargetInt (fromDynTag (funTag platform cl_info))) ]) ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- module GHC.StgToCmm.Closure ( - DynTag, tagForCon, isSmallFamily, + DynTag, tagForCon, isSmallFamily, toDynTag, fromDynTag, idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps, @@ -65,7 +65,7 @@ module GHC.StgToCmm.Closure ( import GHC.Prelude import GHC.Platform -import GHC.Platform.Tag (DynTag, mAX_PTR_TAG, isSmallFamily) +import GHC.Platform.Tag (DynTag, mAX_PTR_TAG, isSmallFamily, toDynTag, fromDynTag) import GHC.Platform.Profile import GHC.Stg.Syntax @@ -320,13 +320,13 @@ mkLFStringLit = LFUnlifted ----------------------------------------------------- tagForCon :: Platform -> DataCon -> DynTag -tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform) --- NB: 1-indexed +-- NB: 1-indexed; result is clamped to mAX_PTR_TAG. +tagForCon platform con = toDynTag platform (min (dataConTag con) (fromDynTag (mAX_PTR_TAG platform))) tagForArity :: Platform -> RepArity -> DynTag tagForArity platform arity - | isSmallFamily platform arity = arity - | otherwise = 0 + | isSmallFamily platform arity = toDynTag platform arity + | otherwise = toDynTag platform 0 -- | Return the tag in the low order bits of a variable bound -- to this LambdaForm @@ -334,7 +334,7 @@ lfDynTag :: Platform -> LambdaFormInfo -> DynTag lfDynTag platform lf = case lf of LFCon con -> tagForCon platform con LFReEntrant _ arity _ _ -> tagForArity platform arity - _other -> 0 + _other -> toDynTag platform 0 ----------------------------------------------------------------------------- ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -90,7 +90,7 @@ idInfoToAmode cg_info -- | A tag adds a byte offset to the pointer addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr -addDynTag = cmmOffsetB +addDynTag platform e tag = cmmOffsetB platform e (fromDynTag tag) maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) maybeLetNoEscape CgIdInfo { cg_loc = LneLoc blk_id args} = Just (blk_id, args) ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -748,7 +748,10 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts !ptag_expr = cmmConstrTag1 platform (CmmReg bndr_reg) !branches' = first succ <$> branches !maxpt = mAX_PTR_TAG platform - (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches' + -- 'maxpt' is a 'DynTag'; branch tables use host-side 'ConTagZ' + -- (= 'Int'), so convert via 'fromDynTag'. + !maxpt_i = fromDynTag maxpt :: ConTagZ + (!via_ptr, !via_info) = partition ((< maxpt_i) . fst) branches' !small = isSmallFamily platform fam_sz -- Is the constructor tag in the node reg? @@ -756,7 +759,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts ; if small || null via_info then -- Yes, bndr_reg has constructor tag in ls bits emitSwitch ptag_expr branches' mb_deflt 1 - (if small then fam_sz else maxpt) + (if small then fam_sz else maxpt_i) else -- No, the get exact tag from info table when mAX_PTR_TAG -- See Note [Double switching for big families] @@ -772,7 +775,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts infos_lbl <- newBlockId infos_scp <- getTickScope - let spillover = (maxpt, (mkBranch infos_lbl, infos_scp)) + let spillover = (maxpt_i, (mkBranch infos_lbl, infos_scp)) (mb_shared_deflt, mb_shared_branch) <- case mb_deflt of (Just (stmts, scp)) -> @@ -781,13 +784,13 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts , Just (mkBranch lbl, scp)) _ -> return (Nothing, Nothing) -- Switch on pointer tag - emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt + emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt_i join_lbl <- newBlockId emit (mkBranch join_lbl) -- Switch on info table tag emitLabel infos_lbl emitSwitch itag_expr info0 mb_shared_branch - (maxpt - 1) (fam_sz - 1) + (maxpt_i - 1) (fam_sz - 1) emitLabel join_lbl ; return AssignedDirectly } ===================================== compiler/GHC/StgToCmm/Foreign.hs ===================================== @@ -621,7 +621,7 @@ openNursery profile tso = do (CmmMachOp (mo_wordMul platform) [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform)) [CmmLoad (nursery_bdescr_blocks platform cnreg) b32 NaturallyAligned] - , mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform)) + , mkIntExpr platform (toTargetInt (pc_BLOCK_SIZE (platformConstants platform))) ]) (-1) ) ===================================== compiler/GHC/StgToCmm/Heap.hs ===================================== @@ -539,7 +539,7 @@ heapCheck checkStack checkYield do_gc code "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.", "Suggestion: read data from a file instead of having large static data", "structures in code."] - | hpHw > 0 = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform))) + | hpHw > 0 = Just (mkIntExpr platform (toTargetInt hpHw * toTargetInt (platformWordSizeInBytes platform))) | otherwise = Nothing where constants = platformConstants platform ===================================== compiler/GHC/StgToCmm/InfoTableProv.hs ===================================== @@ -117,7 +117,7 @@ emitIpeBufferListNode this_mod ents dus0 = do ctx = stgToCmmContext cfg platform = stgToCmmPlatform cfg - int n = mkIntCLit platform n + int n = mkIntCLit platform (toTargetInt n) ((cg_ipes, unit_id, module_name), strtab) = flip runState emptyStringTable $ do unit_id <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr $ moduleName this_mod) ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -241,7 +241,7 @@ slowCall fun stg_args end_lbl <- newBlockId let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr) - (mkIntExpr platform n_args) + (mkIntExpr platform (toTargetInt n_args)) tscope <- getTickScope emit (mkCbranch (cmmIsTagged platform funv) ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -172,7 +172,7 @@ emitPrimOp cfg primop = -> inlinePrimop $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)) - , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))), + , (mkIntExpr platform (toTargetInt (nonHdrSizeW (arrPtrsRep platform (fromInteger n)))), fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform)) ] (fromInteger n) init @@ -2240,7 +2240,7 @@ genericWordAddCOp [res_r, res_c] [aa, bb] CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)] ] ], - mkIntExpr platform (platformWordSizeInBits platform - 1) + mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1)) ] ] genericWordAddCOp _ _ = panic "genericWordAddCOp" @@ -2273,7 +2273,7 @@ genericWordSubCOp [res_r, res_c] [aa, bb] CmmReg (CmmLocal res_r) ] ], - mkIntExpr platform (platformWordSizeInBits platform - 1) + mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1)) ] ] genericWordSubCOp _ _ = panic "genericWordSubCOp" @@ -2309,7 +2309,7 @@ genericIntAddCOp [res_r, res_c] [aa, bb] CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]], CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr platform (platformWordSizeInBits platform - 1) + mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1)) ] ] genericIntAddCOp _ _ = panic "genericIntAddCOp" @@ -2334,7 +2334,7 @@ genericIntSubCOp [res_r, res_c] [aa, bb] CmmMachOp (mo_wordXor platform) [aa,bb], CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr platform (platformWordSizeInBits platform - 1) + mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1)) ] ] genericIntSubCOp _ _ = panic "genericIntSubCOp" @@ -2541,7 +2541,7 @@ doWritePtrArrayOp addr idx val cmmOffsetExpr platform (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) (ptrArraySize platform profile addr)) - (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))]) + (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (toTargetInt (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)))]) ) (CmmLit (CmmInt 1 W8)) mkBasicIndexedRead :: Bool -- Should this imply an acquire barrier @@ -2922,14 +2922,14 @@ doNewByteArrayOp res_r n = do let info_ptr = mkLblExpr mkArrWords_infoLabel rep = arrWordsRep platform n - tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile)) - (mkIntExpr platform (nonHdrSize platform rep)) + tickyAllocPrim (mkIntExpr platform (toTargetInt (arrWordsHdrSize profile))) + (mkIntExpr platform (toTargetInt (nonHdrSize platform rep))) (zeroExpr platform) let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr (cccsExpr platform) - [ (mkIntExpr platform n, + [ (mkIntExpr platform (toTargetInt n), hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) ] @@ -3169,8 +3169,8 @@ doNewArrayOp res_r rep info payload n init = do let info_ptr = mkLblExpr info - tickyAllocPrim (mkIntExpr platform (hdrSize profile rep)) - (mkIntExpr platform (nonHdrSize platform rep)) + tickyAllocPrim (mkIntExpr platform (toTargetInt (hdrSize profile rep))) + (mkIntExpr platform (toTargetInt (nonHdrSize platform rep))) (zeroExpr platform) base <- allocHeapClosure rep info_ptr (cccsExpr platform) payload @@ -3214,7 +3214,7 @@ doCopyArrayOp = emitCopyArray copy -- they're of different types) copy _src _dst dst_p src_p bytes = do platform <- getPlatform - emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform) @@ -3232,9 +3232,9 @@ doCopyMutableArrayOp = emitCopyArray copy copy src dst dst_p src_p bytes = do platform <- getPlatform (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform)) - (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform)) emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall @@ -3257,9 +3257,9 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n = dst_off <- assignTempE dst_off0 whenCheckBounds $ do - emitRangeBoundsCheck src_off (mkIntExpr platform n) + emitRangeBoundsCheck src_off (mkIntExpr platform (toTargetInt n)) (ptrArraySize platform profile src) - emitRangeBoundsCheck dst_off (mkIntExpr platform n) + emitRangeBoundsCheck dst_off (mkIntExpr platform (toTargetInt n)) (ptrArraySize platform profile dst) -- Nonmoving collector write barrier @@ -3291,7 +3291,7 @@ doCopySmallArrayOp = emitCopySmallArray copy -- they're of different types) copy _src _dst dst_p src_p bytes = do platform <- getPlatform - emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform) @@ -3305,9 +3305,9 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy copy src dst dst_p src_p bytes = do platform <- getPlatform (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform)) - (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform)) emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall @@ -3329,9 +3329,9 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n = dst <- assignTempE dst0 whenCheckBounds $ do - emitRangeBoundsCheck src_off (mkIntExpr platform n) + emitRangeBoundsCheck src_off (mkIntExpr platform (toTargetInt n)) (smallPtrArraySize platform profile src) - emitRangeBoundsCheck dst_off (mkIntExpr platform n) + emitRangeBoundsCheck dst_off (mkIntExpr platform (toTargetInt n)) (smallPtrArraySize platform profile dst) -- Nonmoving collector write barrier @@ -3361,17 +3361,17 @@ emitCloneArray info_p res_r src src_off n = do let info_ptr = mkLblExpr info_p rep = arrPtrsRep platform n - tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile)) - (mkIntExpr platform (nonHdrSize platform rep)) + tickyAllocPrim (mkIntExpr platform (toTargetInt (arrPtrsHdrSize profile))) + (mkIntExpr platform (toTargetInt (nonHdrSize platform rep))) (zeroExpr platform) let hdr_size = fixedHdrSize profile constants = platformConstants platform base <- allocHeapClosure rep info_ptr (cccsExpr platform) - [ (mkIntExpr platform n, + [ (mkIntExpr platform (toTargetInt n), hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) - , (mkIntExpr platform (nonHdrSizeW rep), + , (mkIntExpr platform (toTargetInt (nonHdrSizeW rep)), hdr_size + pc_OFFSET_StgMutArrPtrs_size constants) ] @@ -3382,9 +3382,9 @@ emitCloneArray info_p res_r src src_off n = do (arrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform - (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off) + (mkIntExpr platform (toTargetInt (arrPtrsHdrSizeW profile))) src_off) - emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt (wordsToBytes platform n))) (wordAlignment platform) emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -3402,14 +3402,14 @@ emitCloneSmallArray info_p res_r src src_off n = do let info_ptr = mkLblExpr info_p rep = smallArrPtrsRep n - tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile)) - (mkIntExpr platform (nonHdrSize platform rep)) + tickyAllocPrim (mkIntExpr platform (toTargetInt (smallArrPtrsHdrSize profile))) + (mkIntExpr platform (toTargetInt (nonHdrSize platform rep))) (zeroExpr platform) let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr (cccsExpr platform) - [ (mkIntExpr platform n, + [ (mkIntExpr platform (toTargetInt n), hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] @@ -3420,9 +3420,9 @@ emitCloneSmallArray info_p res_r src src_off n = do (smallArrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform - (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off) + (mkIntExpr platform (toTargetInt (smallArrPtrsHdrSizeW profile))) src_off) - emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt (wordsToBytes platform n))) (wordAlignment platform) emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -3437,7 +3437,7 @@ emitSetCards dst_start dst_cards_start n = do start_card <- assignTempE $ cardCmm platform dst_start let end_card = cardCmm platform (cmmSubWord platform - (cmmAddWord platform dst_start (mkIntExpr platform n)) + (cmmAddWord platform dst_start (mkIntExpr platform (toTargetInt n))) (mkIntExpr platform 1)) emitMemsetCall (cmmAddWord platform dst_cards_start start_card) (mkIntExpr platform 1) @@ -3447,7 +3447,7 @@ emitSetCards dst_start dst_cards_start n = do -- Convert an element index to a card index cardCmm :: Platform -> CmmExpr -> CmmExpr cardCmm platform i = - cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))) + cmmUShrWord platform i (mkIntExpr platform (toTargetInt (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)))) ------------------------------------------------------------------------------ -- SmallArray PrimOp implementations @@ -3794,10 +3794,10 @@ doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do platform <- getPlatform let elem_w = typeWidth elem_ty idx_w = typeWidth idx_ty - elem_sz = mkIntExpr platform $ widthInBytes elem_w + elem_sz = mkIntExpr platform $ toTargetInt (widthInBytes elem_w) arr_sz = byteArraySize platform profile arr effective_arr_sz = - cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w)) + cmmUShrWord platform arr_sz (mkIntExpr platform (toTargetInt (widthInLog idx_w))) if elem_w == idx_w then emitBoundsCheck idx effective_arr_sz -- aligned => simpler check else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz) @@ -3839,8 +3839,8 @@ emitCopyUpdRemSetPush platform hdr_size dst dst_off n = lbl = mkLblExpr $ mkPrimCallLabel $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit args = - [ mkIntExpr platform hdr_size + [ mkIntExpr platform (toTargetInt hdr_size) , dst , dst_off - , mkIntExpr platform n + , mkIntExpr platform (toTargetInt n) ] ===================================== compiler/GHC/StgToCmm/Prof.hs ===================================== @@ -166,7 +166,7 @@ profDynAlloc rep ccs = ifProfiling $ do profile <- getProfile let platform = profilePlatform profile - profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs + profAlloc (mkIntExpr platform (toTargetInt (heapClosureSizeW profile rep))) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -182,7 +182,7 @@ profAlloc words ccs (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) -- subtract the "profiling overhead", which is the -- profiling header in a closure. - [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]] + [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (toTargetInt (profHdrSize profile))]] ) -- ----------------------------------------------------------------------- @@ -224,7 +224,7 @@ emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do { ctx <- stgToCmmContext <$> getStgToCmmConfig ; platform <- getPlatform - ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF + ; let is_caf | isCafCC cc = mkIntCLit platform (toTargetInt (ord 'c')) -- 'c' == is a CAF | otherwise = zero platform -- NB. bytesFS: we want the UTF-8 bytes here (#5559) ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) @@ -347,7 +347,7 @@ dynLdvInit :: Platform -> CmmExpr dynLdvInit platform = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr platform) [ - CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))], + CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (toTargetInt (pc_LDV_SHIFT (platformConstants platform)))], CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform))) ] @@ -390,7 +390,7 @@ ldvEnterClosure closure_info node_reg = do platform <- getPlatform let tag = funTag platform closure_info -- don't forget to subtract node's tag - ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag)) + ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-(fromDynTag tag))) ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ===================================== compiler/GHC/StgToCmm/Ticky.hs ===================================== @@ -294,7 +294,7 @@ emitTickyData platform ctr_lbl arity fun_desc arg_desc json_desc info_tbl = -- before, but the code generator wasn't handling that -- properly and it led to chaos, panic and disorder. [ zeroCLit platform, -- registered? - mkIntCLit platform arity, -- Arity + mkIntCLit platform (toTargetInt arity), -- Arity zeroCLit platform, -- Heap allocated for this thing fun_desc, arg_desc, @@ -848,7 +848,7 @@ bumpHistogram lbl n = do emitAddToMem :: CmmExpr -> Int -> FCode () emitAddToMem lhs n = do platform <- getPlatform - emitAddToMemE lhs (mkIntExpr platform n) + emitAddToMemE lhs (mkIntExpr platform (toTargetInt n)) emitAddToMemE :: CmmExpr -> CmmExpr -> FCode () emitAddToMemE lhs n = do ===================================== compiler/GHC/StgToCmm/Utils.hs ===================================== @@ -160,7 +160,7 @@ mkTaggedObjectLoad platform reg base offset tag = mkAssign (CmmLocal reg) (CmmLoad (cmmOffsetB platform (CmmReg (CmmLocal base)) - (offset - tag)) + (offset - fromDynTag tag)) (localRegType reg) NaturallyAligned) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2367,8 +2367,9 @@ tcUserStmt (L loc (BodyStmt _ expr _ _)) -- The two-step process avoids getting two errors: one from -- the expression itself, and one from the 'print it' part -- This two-step story is very clunky, alas - , do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + , do { _ <- checkNoErrs (discardWarnings (tcGhciStmts [let_stmt])) --- checkNoErrs defeats the error recovery of let-bindings + --- discardWarnings: warnings come from the second typecheck ; tcGhciStmts [let_stmt, print_it] } ] -- Plans where we don't bind "it" ===================================== docs/users_guide/packages.rst ===================================== @@ -600,7 +600,7 @@ must be relative to the location of the package environment file. :category: Use the package environment in ⟨file⟩, or in - ``$XDG_DATA_HOME/ghc/arch-os-version/environments/⟨name⟩`` + ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/⟨name⟩`` If set to ``-`` no package environment is read. .. envvar:: GHC_ENVIRONMENT @@ -613,13 +613,13 @@ locations: - File ⟨file⟩ if you pass the option :ghc-flag:`-package-env ⟨file⟩|⟨name⟩`. -- File ``$XDG_DATA_HOME/ghc/arch-os-version/environments/name`` if you pass the +- File ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/name`` if you pass the option ``-package-env ⟨name⟩``. - File ⟨file⟩ if the environment variable :envvar:`GHC_ENVIRONMENT` is set to ⟨file⟩. -- File ``$XDG_DATA_HOME/ghc/arch-os-version/environments/name`` if the +- File ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/name`` if the environment variable :envvar:`GHC_ENVIRONMENT` is set to ⟨name⟩. Additionally, unless ``-hide-all-packages`` is specified ``ghc`` will also @@ -628,7 +628,7 @@ look for the package environment in the following locations: - File ``.ghc.environment.arch-os-version`` if it exists in the current directory or any parent directory (but not the user's home directory). -- File ``$XDG_DATA_HOME/ghc/arch-os-version/environments/default`` if it +- File ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/default`` if it exists. Package environments can be modified by further command line arguments; ===================================== testsuite/tests/deSugar/should_compile/T25996.hs ===================================== @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +main :: IO () +main = do + pure () + where + biz :: IO () + biz = do + pure (10 :: Integer) + pure () + +biz' :: IO () +biz' = do + pure (10 :: Integer) + pure () ===================================== testsuite/tests/deSugar/should_compile/T25996.stderr ===================================== @@ -0,0 +1,10 @@ +T25996.hs:11:7: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] + A do-notation statement discarded a result of type ‘Integer’ + Suggested fix: + Suppress this warning by saying ‘_ <- pure (10 :: Integer)’ + +T25996.hs:16:3: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] + A do-notation statement discarded a result of type ‘Integer’ + Suggested fix: + Suppress this warning by saying ‘_ <- pure (10 :: Integer)’ + ===================================== testsuite/tests/deSugar/should_compile/all.T ===================================== @@ -115,3 +115,4 @@ test('T19883', normal, compile, ['']) test('T22719', normal, compile, ['-ddump-simpl -dsuppress-uniques -dno-typeable-binds']) test('T23550', normal, compile, ['']) test('T24489', normal, compile, ['-O']) +test('T25996', normal, compile, ['']) ===================================== testsuite/tests/ghci/scripts/T26233.script ===================================== @@ -0,0 +1,2 @@ +:set -Wall +truncate pi ===================================== testsuite/tests/ghci/scripts/T26233.stderr ===================================== @@ -0,0 +1,14 @@ +<interactive>:2:1: warning: [GHC-18042] [-Wtype-defaults (in -Wall)] + • Defaulting the type variable ‘a0’ to type ‘Double’ in the following constraints + (RealFrac a0) + arising from a use of ‘truncate’ at <interactive>:2:1-8 + (Floating a0) arising from a use of ‘pi’ at <interactive>:2:10-11 + • In the expression: truncate pi + In an equation for ‘it’: it = truncate pi + +<interactive>:2:1: warning: [GHC-18042] [-Wtype-defaults (in -Wall)] + • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraints + (Show a0) arising from a use of ‘print’ at <interactive>:2:1-11 + (Integral a0) arising from a use of ‘it’ at <interactive>:2:1-11 + • In a stmt of an interactive GHCi command: print it + ===================================== testsuite/tests/ghci/scripts/T26233.stdout ===================================== @@ -0,0 +1 @@ +3 ===================================== testsuite/tests/ghci/scripts/all.T ===================================== @@ -391,3 +391,4 @@ test('GhciPackageRename', [extra_hc_opts("-hide-all-packages -package 'containers (Data.Map as Prelude)'")], ghci_script, ['GhciPackageRename.script']) +test('T26233', normal, ghci_script, ['T26233.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/736cb42dd897b68f40fe71aa653df0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/736cb42dd897b68f40fe71aa653df0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] 15 commits: Bump directory submodule to 1.3.11.0 (unreleased)
by Hannes Siebenhandl (＠fendor) 13 Apr '26

13 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: b135a87d by Zubin Duggal at 2026-04-09T19:36:50+05:30 Bump directory submodule to 1.3.11.0 (unreleased) - - - - - 3a291d07 by Zubin Duggal at 2026-04-09T19:36:50+05:30 Bump file-io submodule to 0.2.0 - - - - - e0ab606d by Zubin Duggal at 2026-04-10T18:40:20+05:30 Release notes for GHC 10.0 - - - - - e08b9b34 by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump ghc-prim version to 0.14.0 - - - - - a92aac6e by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump template-haskell to 2.25.0.0; update submodule exceptions for TH 2.25 - - - - - f254d9e8 by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump GHC version to 10.0 - - - - - 6ce0368a by Zubin Duggal at 2026-04-10T18:40:28+05:30 Bump base to 4.23.0.0; update submodules for base 4.24 upper bound - - - - - 702fb8a5 by Zubin Duggal at 2026-04-10T18:40:28+05:30 Bump GHC version to 10.1; update submodules template-haskell-lift and template-haskell-quasiquoter for ghc-internal 10.200 - - - - - 75df1ca4 by Zubin Duggal at 2026-04-10T18:40:28+05:30 Use changelog.d for release notes (#26002) GHC now uses a fragment-based changelog workflow using a custom script adapted from https://codeberg.org/fgaz/changelog-d. Contributors add a file in changelog.d/ for each user-facing change. At release time, these are assembled into release notes for sphinx (in RST) format, using the tool. New hadrian `changelog` target to generate changelogs CI job to validate changelog entries for MRs unless skipped with ~"no-changelog" label Teach sphinx about ghc-mr: extlink to link to MRs Remove `ghc-package-list` from sphinx, and implement it in changelog-d instead (Fixes #26476). (cherry picked from commit 989c07249978f418dfde1353abfad453f024d61a) - - - - - 585d7450 by Luite Stegeman at 2026-04-11T02:17:13-04:00 tc: discard warnings in tcUserStmt Plan C We typecheck let_stmt twice, but we don't want the warnings twice! see #26233 - - - - - 2df604e9 by Sylvain Henry at 2026-04-11T02:19:30-04:00 Introduce TargetInt to represent target's Int (#15973) GHC was using host 'Int' in several places to represent values that live in the target machine's 'Int' type. This is silently wrong when cross-compiling from a 32-bit host to a 64-bit target: the host Int is 32 bits while the target Int is 64 bits. See Note [TargetInt] in GHC.Platform. Also used the opportunity to make DynTag = Word8. Fixes #15973 Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 08c62e8e by fendor at 2026-04-13T09:41:33+02:00 Expose startupHpc as an rts symbol - - - - - 5590f1d0 by fendor at 2026-04-13T09:41:33+02:00 Make HPC work with bytecode interpreter Add support to generate .tix files from bytecode objects and the bytecode interpreter. Conceptually, we insert HPC ticks into the bytecode similar to how we insert breakpoints. HPC and breakpoints do not share the same tick array but we use a separate tick-array for hpc/breakpoint ticks during bytecode generation. We teach the bytecode interpreter to handle hpc ticks. The implementation is quite trivial, simply increment the counter in the global hpc_ticks array for the respective module. This hpc_ticks array is generated as part of the `CStub`, so we can rely on it existing. A tricky bit is "registering" a bytecode object for HPC instrumentation. In the compiled case, this is achieved via CStub and initializer/finalizers `.init` sections which are called when the executable is run. After the initializers have been invoked, which is before `hs_init_ghc`, we then call `startup_hpc` in `hs_init_ghc` iff any modules were "registered" for hpc instrumentation via `hs_hpc_module`. Since bytecode objects are loaded after starting up GHCi, this workflow doesn't work for supporting `hpc` and the `hpc` run-time is never started, even if a module is added for instrumentation. We fix this issue by employing the same technique as is for `SptEntry`s: * We introduce a new field to `CompiledByteCode`, called `ByteCodeHpcInfo` which contains enough information to call `hs_hpc_module`, allowing us to register the module for `hpc` instrumentation`. * After registering the module, we unconditionally call `startupHpc`, to make sure the .tix file is written. Calling `startupHpc` multiple times is safe. Calling `hs_hpc_module` multiple times for the same module is also safe. If we didn't register the hpc module in this way, evaluating a bytecode object instrumented with `-fhpc` without registering it in the `hpc` run-time will simply not generate any `.tix` files for this bytecode object. However, this shouldn't happen if everything is set up correctly. Closes #27036 - - - - - 24559f0a by fendor at 2026-04-13T09:41:33+02:00 Use common module name printing function - - - - - 7883e5f1 by fendor at 2026-04-13T09:47:36+02:00 fixup! Make HPC work with bytecode interpreter - - - - - 140 changed files: - .gitlab-ci.yml - .gitlab/issue_templates/release_tracking.md - .gitlab/merge_request_templates/Default.md - + changelog.d/bytecode-interpreter-hpc-support - + changelog.d/changelog-entries - + changelog.d/config - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/LayoutStack.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Coverage.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Platform.hs - compiler/GHC/Platform/Tag.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Heap.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Prof.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/HpcInfo.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/ghc.cabal.in - configure.ac - − docs/users_guide/10.0.1-notes.rst - + docs/users_guide/10.2.1-notes.rst - − docs/users_guide/9.16.1-notes.rst - docs/users_guide/conf.py - docs/users_guide/ghc_config.py.in - − docs/users_guide/ghc_packages.py - docs/users_guide/release-notes.rst - ghc/ghc-bin.cabal.in - hadrian/hadrian.cabal - hadrian/src/CommandLine.hs - hadrian/src/Main.hs - hadrian/src/Packages.hs - + hadrian/src/Rules/Changelog.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Default.hs - libraries/array - libraries/base/base.cabal.in - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/file-io - libraries/filepath - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-compact/ghc-compact.cabal - libraries/ghc-experimental/ghc-experimental.cabal.in - libraries/ghc-prim/changelog.md - libraries/ghc-prim/ghc-prim.cabal - + libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/template-haskell-lift - libraries/template-haskell-quasiquoter - libraries/template-haskell/template-haskell.cabal.in - libraries/terminfo - libraries/unix - m4/fp_setup_project_version.m4 - m4/fptools_ghc_version.m4 - rts/Disassembler.c - rts/Hpc.c - rts/Interpreter.c - rts/RtsSymbols.c - rts/include/rts/Bytecodes.h - testsuite/mk/boilerplate.mk - + testsuite/tests/ghci/scripts/T26233.script - + testsuite/tests/ghci/scripts/T26233.stderr - + testsuite/tests/ghci/scripts/T26233.stdout - testsuite/tests/ghci/scripts/all.T - testsuite/tests/hpc/Makefile - testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout - + testsuite/tests/hpc/T17073b.stdout - testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout - + testsuite/tests/hpc/T20568b.stdout - testsuite/tests/hpc/all.T - testsuite/tests/hpc/fork/Makefile - testsuite/tests/hpc/function/Makefile - testsuite/tests/hpc/function/test.T - + testsuite/tests/hpc/function/tough1.stderr - + testsuite/tests/hpc/function/tough1.stdout - testsuite/tests/hpc/function2/test.T - + testsuite/tests/hpc/function2/tough3.script - + testsuite/tests/hpc/ghc_ghci/BytecodeMain.hs - testsuite/tests/hpc/ghc_ghci/Makefile - + testsuite/tests/hpc/ghc_ghci/hpc_ghc_ghci_bytecode.stdout - testsuite/tests/hpc/ghc_ghci/test.T - testsuite/tests/hpc/hpcrun.pl - testsuite/tests/hpc/simple/Makefile - + testsuite/tests/hpc/simple/hpc002.hs - + testsuite/tests/hpc/simple/hpc002.stdout - + testsuite/tests/hpc/simple/hpc003.hs - + testsuite/tests/hpc/simple/hpc003.script - + testsuite/tests/hpc/simple/hpc003.stderr - + testsuite/tests/hpc/simple/hpc003.stdout - testsuite/tests/hpc/simple/test.T - testsuite/tests/linters/Makefile - testsuite/tests/linters/all.T - + testsuite/tests/linters/changelog-d.stdout - + utils/changelog-d/ChangelogD.hs - + utils/changelog-d/LICENSE - + utils/changelog-d/README.md - + utils/changelog-d/changelog-d.cabal - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/haddock-test/haddock-test.cabal - utils/haddock/haddock.cabal - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75871f1339c57d8a76a106a7e01fea… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75871f1339c57d8a76a106a7e01fea… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] 2 commits: Make HPC work with bytecode interpreter
by Hannes Siebenhandl (＠fendor) 13 Apr '26

13 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 68d14d52 by fendor at 2026-04-13T09:39:41+02:00 Make HPC work with bytecode interpreter Add support to generate .tix files from bytecode objects and the bytecode interpreter. Conceptually, we insert HPC ticks into the bytecode similar to how we insert breakpoints. HPC and breakpoints do not share the same tick array but we use a separate tick-array for hpc/breakpoint ticks during bytecode generation. We teach the bytecode interpreter to handle hpc ticks. The implementation is quite trivial, simply increment the counter in the global hpc_ticks array for the respective module. This hpc_ticks array is generated as part of the `CStub`, so we can rely on it existing. A tricky bit is "registering" a bytecode object for HPC instrumentation. In the compiled case, this is achieved via CStub and initializer/finalizers `.init` sections which are called when the executable is run. After the initializers have been invoked, which is before `hs_init_ghc`, we then call `startup_hpc` in `hs_init_ghc` iff any modules were "registered" for hpc instrumentation via `hs_hpc_module`. Since bytecode objects are loaded after starting up GHCi, this workflow doesn't work for supporting `hpc` and the `hpc` run-time is never started, even if a module is added for instrumentation. We fix this issue by employing the same technique as is for `SptEntry`s: * We introduce a new field to `CompiledByteCode`, called `ByteCodeHpcInfo` which contains enough information to call `hs_hpc_module`, allowing us to register the module for `hpc` instrumentation`. * After registering the module, we unconditionally call `startupHpc`, to make sure the .tix file is written. Calling `startupHpc` multiple times is safe. Calling `hs_hpc_module` multiple times for the same module is also safe. If we didn't register the hpc module in this way, evaluating a bytecode object instrumented with `-fhpc` without registering it in the `hpc` run-time will simply not generate any `.tix` files for this bytecode object. However, this shouldn't happen if everything is set up correctly. Closes #27036 - - - - - 75871f13 by fendor at 2026-04-13T09:39:41+02:00 Use common module name printing function - - - - - 51 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Coverage.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/HpcInfo.hs - compiler/GHC/Unit/Module/ModGuts.hs - + libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Disassembler.c - rts/Hpc.c - rts/Interpreter.c - rts/include/rts/Bytecodes.h - testsuite/tests/hpc/Makefile - testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout - + testsuite/tests/hpc/T17073b.stdout - testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout - + testsuite/tests/hpc/T20568b.stdout - testsuite/tests/hpc/all.T - testsuite/tests/hpc/fork/Makefile - testsuite/tests/hpc/function/Makefile - testsuite/tests/hpc/function/test.T - + testsuite/tests/hpc/function/tough1.stderr - + testsuite/tests/hpc/function/tough1.stdout - testsuite/tests/hpc/function2/test.T - + testsuite/tests/hpc/function2/tough3.script - + testsuite/tests/hpc/ghc_ghci/BytecodeMain.hs - testsuite/tests/hpc/ghc_ghci/Makefile - + testsuite/tests/hpc/ghc_ghci/hpc_ghc_ghci_bytecode.stdout - testsuite/tests/hpc/ghc_ghci/test.T - testsuite/tests/hpc/hpcrun.pl - testsuite/tests/hpc/simple/Makefile - + testsuite/tests/hpc/simple/hpc002.hs - + testsuite/tests/hpc/simple/hpc002.stdout - + testsuite/tests/hpc/simple/hpc003.hs - + testsuite/tests/hpc/simple/hpc003.script - + testsuite/tests/hpc/simple/hpc003.stderr - + testsuite/tests/hpc/simple/hpc003.stdout - testsuite/tests/hpc/simple/test.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7fb0b183167613ec461f379ef64586… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7fb0b183167613ec461f379ef64586… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] Use common module name printing function
by Hannes Siebenhandl (＠fendor) 13 Apr '26

13 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 7fb0b183 by fendor at 2026-04-13T09:31:02+02:00 Use common module name printing function - - - - - 1 changed file: - compiler/GHC/HsToCore/Coverage.hs Changes: ===================================== compiler/GHC/HsToCore/Coverage.hs ===================================== @@ -158,4 +158,4 @@ mkHpcTickLabel platform mod = mkHpcModuleLabel :: Module -> String mkHpcModuleLabel mod = - showSDocOneLine defaultSDocContext (pprCode $ ppr mod) + showSDocOneLine defaultSDocContext (pprCode $ hpcModuleName mod) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fb0b183167613ec461f379ef645866… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fb0b183167613ec461f379ef645866… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] Make HPC work with bytecode interpreter
by Hannes Siebenhandl (＠fendor) 13 Apr '26

13 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 2169ba58 by fendor at 2026-04-13T09:26:03+02:00 Make HPC work with bytecode interpreter Add support to generate .tix files from bytecode objects and the bytecode interpreter. Conceptually, we insert HPC ticks into the bytecode similar to how we insert breakpoints. HPC and breakpoints do not share the same tick array but we use a separate tick-array for hpc/breakpoint ticks during bytecode generation. We teach the bytecode interpreter to handle hpc ticks. The implementation is quite trivial, simply increment the counter in the global hpc_ticks array for the respective module. This hpc_ticks array is generated as part of the `CStub`, so we can rely on it existing. A tricky bit is "registering" a bytecode object for HPC instrumentation. In the compiled case, this is achieved via CStub and initializer/finalizers `.init` sections which are called when the executable is run. After the initializers have been invoked, which is before `hs_init_ghc`, we then call `startup_hpc` in `hs_init_ghc` iff any modules were "registered" for hpc instrumentation via `hs_hpc_module`. Since bytecode objects are loaded after starting up GHCi, this workflow doesn't work for supporting `hpc` and the `hpc` run-time is never started, even if a module is added for instrumentation. We fix this issue by employing the same technique as is for `SptEntry`s: * We introduce a new field to `CompiledByteCode`, called `ByteCodeHpcInfo` which contains enough information to call `hs_hpc_module`, allowing us to register the module for `hpc` instrumentation`. * After registering the module, we unconditionally call `startupHpc`, to make sure the .tix file is written. Calling `startupHpc` multiple times is safe. Calling `hs_hpc_module` multiple times for the same module is also safe. If we didn't register the hpc module in this way, evaluating a bytecode object instrumented with `-fhpc` without registering it in the `hpc` run-time will simply not generate any `.tix` files for this bytecode object. However, this shouldn't happen if everything is set up correctly. Closes #27036 - - - - - 51 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Coverage.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/HpcInfo.hs - compiler/GHC/Unit/Module/ModGuts.hs - + libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Disassembler.c - rts/Hpc.c - rts/Interpreter.c - rts/include/rts/Bytecodes.h - testsuite/tests/hpc/Makefile - testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout - + testsuite/tests/hpc/T17073b.stdout - testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout - + testsuite/tests/hpc/T20568b.stdout - testsuite/tests/hpc/all.T - testsuite/tests/hpc/fork/Makefile - testsuite/tests/hpc/function/Makefile - testsuite/tests/hpc/function/test.T - + testsuite/tests/hpc/function/tough1.stderr - + testsuite/tests/hpc/function/tough1.stdout - testsuite/tests/hpc/function2/test.T - + testsuite/tests/hpc/function2/tough3.script - + testsuite/tests/hpc/ghc_ghci/BytecodeMain.hs - testsuite/tests/hpc/ghc_ghci/Makefile - + testsuite/tests/hpc/ghc_ghci/hpc_ghc_ghci_bytecode.stdout - testsuite/tests/hpc/ghc_ghci/test.T - testsuite/tests/hpc/hpcrun.pl - testsuite/tests/hpc/simple/Makefile - + testsuite/tests/hpc/simple/hpc002.hs - + testsuite/tests/hpc/simple/hpc002.stdout - + testsuite/tests/hpc/simple/hpc003.hs - + testsuite/tests/hpc/simple/hpc003.script - + testsuite/tests/hpc/simple/hpc003.stderr - + testsuite/tests/hpc/simple/hpc003.stdout - testsuite/tests/hpc/simple/test.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2169ba58505b46032346792404bb962… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2169ba58505b46032346792404bb962… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26989] More small wibbles
by Simon Peyton Jones (＠simonpj) 12 Apr '26

12 Apr '26

Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 1100029e by Simon Peyton Jones at 2026-04-13T00:09:18+01:00 More small wibbles The important change here is in preInlineUnconditionally - - - - - 3 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Ppr.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -283,7 +283,7 @@ simplRecOrTopPair :: SimplEnv simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) - old_bndr rhs env + old_bndr NoDup rhs env = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $ do { tick (PreInlineUnconditionally old_bndr) @@ -1298,7 +1298,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont do { ty' <- simplType env ty ; simplExprF (extendTvSubst env bndr ty') body cont } - | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env + | Just env' <- preInlineUnconditionally env NotTopLevel bndr NoDup rhs env -- Because of the let-can-float invariant, it's ok to -- inline freely, or to drop the binding if it is dead. = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $ @@ -1869,7 +1869,7 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se -- It's wrong to err in either direction -- But fun_ty is an OutType, so is fully substituted - ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se + ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr dup arg arg_se , not (needsCaseBindingL arg_levity arg) -- Ok to test arg::InExpr in needsCaseBinding because -- exprOkForSpeculation is stable under simplification @@ -2686,10 +2686,9 @@ tryRules env rules fn args | Just rule_match <- lookupRule ropts in_scope_env act_fun fn args rules -- Fire a rule for the function - = do { let the_rule = rm_rule rule_match - ; logger <- getLogger - ; checkedTick (RuleFired (ruleName the_rule)) - ; dump logger the_rule (rm_rhs rule_match) + = do { logger <- getLogger + ; checkedTick (RuleFired (ruleName (rm_rule rule_match))) + ; dump logger rule_match ; return (Just rule_match) } | otherwise -- No rule fires @@ -2707,7 +2706,7 @@ tryRules env rules fn args (pprModuleName . moduleName) (ruleModule rule)) - dump logger rule rule_rhs + dump logger (RM { rm_rule = rule, rm_rhs = rhs, rm_args = rule_args }) | logHasDumpFlag logger Opt_D_dump_rule_rewrites = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat [ text "Rule:" <+> ftext (ruleName rule) @@ -2716,7 +2715,8 @@ tryRules env rules fn args --, text "Rule activation:" <+> ppr (ruleActivation rule) , text "Full arity:" <+> ppr (ruleArity rule) , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) - , text "After: " <+> pprCoreExpr rule_rhs ] + , text "After:" <+> pprCoreExpr (mkApps rhs rule_args) + ] | logHasDumpFlag logger Opt_D_dump_rule_firings = log_rule Opt_D_dump_rule_firings "Rule fired:" $ @@ -3838,7 +3838,7 @@ knownCon env scrut dc dc_args case_bndr alt_bndrs rhs cont return ( emptyFloats env , extendIdSubst env case_bndr (DoneEx scrut NotJoinPoint)) - | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr con_app env + | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr NoDup con_app env = return (emptyFloats env', env') | otherwise ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1565,13 +1565,13 @@ the former. preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId - -> InExpr -> StaticEnv -- These two go together + -> DupFlag -> InExpr -> StaticEnv -- These three go together -> Maybe SimplEnv -- Returned env has extended substitution -- Precondition: rhs satisfies the let-can-float invariant -- See Note [Core let-can-float invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, -- for unlifted, side-effect-ful bindings -preInlineUnconditionally env top_lvl bndr rhs rhs_env +preInlineUnconditionally env top_lvl bndr dup rhs rhs_env | not pre_inline_unconditionally = Nothing | not active = Nothing | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] @@ -1584,10 +1584,17 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env -- See Note [Stable unfoldings and preInlineUnconditionally] | not (isInlinePragma inline_prag) , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl) + | otherwise = Nothing where unf = idUnfolding bndr - extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs) + + -- If the rhs is already simplified, then extend the envt with DoneEx; + -- If not then ContEx + -- ToDo: flesh this note out + extend_subst_with inl_rhs + | isSimplified dup = extendIdSubst env bndr $! DoneEx inl_rhs NotJoinPoint + | otherwise = extendIdSubst env bndr $! mkContEx rhs_env inl_rhs one_occ IAmDead = True -- Happens in ((\x.1) v) one_occ OneOcc{ occ_n_br = 1 ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -430,19 +430,20 @@ pprTypedLamBinder bind_site debug_on var = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs -> case () of _ - | not debug_on -- Show case-bound wild binders only if debug is on + -- Show case-bound wild binders only if debug is on + | not debug_on , CaseBind <- bind_site - , isDeadBinder var -> empty + -> if isDeadBinder var + then empty + else pprUntypedBinder var + -- Show binders as "_" in case patterns + -- (but not in RULES or let) | not debug_on -- Even dead binders can be one-shot - , isDeadBinder var -> char '_' <+> ppWhen (isId var) - (pprIdBndrInfo (idInfo var)) - - | not debug_on -- No parens, no kind info - , CaseBind <- bind_site -> pprUntypedBinder var - - | not debug_on - , CasePatBind <- bind_site -> pprUntypedBinder var + , CasePatBind <- bind_site + -> if (isDeadBinder var) + then char '_' <+> ppWhen (isId var) (pprIdBndrInfo (idInfo var)) + else pprUntypedBinder var | suppress_sigs -> pprUntypedBinder var View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1100029edbec6fb6799a45cc28c9c3c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1100029edbec6fb6799a45cc28c9c3c… You're receiving this email because of your account on gitlab.haskell.org.

1 0