May 2025 - ghc-commits

[Git][ghc/ghc][wip/T25974] Relax the requirements of `set_up_tarballs` Windows toolchain check
by Serge S. Gulin (＠gulin.serge) 15 May '25

15 May '25

Serge S. Gulin pushed to branch wip/T25974 at Glasgow Haskell Compiler / GHC Commits: 49d94b1d by Serge S. Gulin at 2025-05-15T15:26:22+04:00 Relax the requirements of `set_up_tarballs` Windows toolchain check - - - - - 5 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - hadrian/src/Builder.hs - hadrian/src/Rules/BinaryDist.hs - m4/fp_setup_windows_toolchain.m4 Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -873,10 +873,6 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} } , "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh configure" -- We have to trigger cabal build in an independent way to mitigate Wine hangs at MSYS2/Arm64EC , "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l -c './hadrian/build-cabal clean'" - -- We use "--enable-distro-toolchain" due of TOOLCHAIN_SOURCE="env", so we have to manually copy - -- bootstrap's compiler mingw into `_build` because binary-dist-dir requires it at Windows. - -- After './hadrian/build-cabal clean' we have to recreate the build root directory. - , "mkdir ./_build && cp -r ~/.wine/drive_c/msys64/opt/ghc-bootstrap/mingw ./_build/" , "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh build_hadrian" , "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh test_hadrian" ] ===================================== .gitlab/jobs.yaml ===================================== @@ -523,7 +523,6 @@ "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh setup", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh configure", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l -c './hadrian/build-cabal clean'", - "mkdir ./_build && cp -r ~/.wine/drive_c/msys64/opt/ghc-bootstrap/mingw ./_build/", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh build_hadrian", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh test_hadrian" ], @@ -1281,7 +1280,6 @@ "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh setup", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh configure", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l -c './hadrian/build-cabal clean'", - "mkdir ./_build && cp -r ~/.wine/drive_c/msys64/opt/ghc-bootstrap/mingw ./_build/", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh build_hadrian", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh test_hadrian" ], ===================================== hadrian/src/Builder.hs ===================================== @@ -26,7 +26,7 @@ import Hadrian.Builder.Tar import Hadrian.Oracles.Path import Hadrian.Oracles.TextFile import Hadrian.Utilities -import Oracles.Setting (bashPath, targetStage, isWinHost) +import Oracles.Setting (bashPath, targetStage, isWinHost, isWinTarget) import System.Exit import System.IO (stderr) @@ -240,12 +240,14 @@ instance H.Builder Builder where Ghc _ st -> do root <- buildRoot unlitPath <- builderPath Unlit + win_target <- isWinTarget + win_host <- isWinHost distro_mingw <- settingsFileSetting ToolchainSetting_DistroMinGW libffi_adjustors <- useLibffiForAdjustors use_system_ffi <- flag UseSystemFfi return $ [ unlitPath ] - ++ [ root -/- mingwStamp | windowsHost, distro_mingw == "NO" ] + ++ [ root -/- mingwStamp | win_target, win_host, distro_mingw == "NO" ] -- proxy for the entire mingw toolchain that -- we have in inplace/mingw initially, and then at -- root -/- mingw. ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -256,7 +256,10 @@ bindistRules = do copyFile ("libraries" -/- "prologue.txt") (bindistFilesDir -/- "docs-utils" -/- "prologue.txt") copyFile ("libraries" -/- "gen_contents_index") (bindistFilesDir -/- "docs-utils" -/- "gen_contents_index" ) - when windowsHost $ do + win_host <- isWinHost + win_target <- isWinTarget + distro_mingw <- settingsFileSetting ToolchainSetting_DistroMinGW + when (win_host && win_target && distro_mingw == "NO") $ do copyDirectory (root -/- "mingw") bindistFilesDir -- we use that opportunity to delete the .stamp file that we use -- as a proxy for the whole mingw toolchain, there's no point in ===================================== m4/fp_setup_windows_toolchain.m4 ===================================== @@ -9,7 +9,19 @@ AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[ fi set_up_tarballs() { - AC_MSG_NOTICE([Checking for Windows toolchain tarballs...]) + AC_MSG_CHECKING([for Windows toolchain tarballs...]) + + # We are leaving an option to substitute the toolchain with manually prepared one at the CI due of cross-compile targets. + # Builtin toolchain does not support cross-compile nor we have other reasons why it should. + # Probably we shouldn't ship GHC with a built-in toolchain for all cross-compile options. + # Cross-compile support is a relatively new and experimental option for Windows target but + # important to support AArch64. Same as Darwin. + if test -d inplace/mingw + then + AC_MSG_RESULT([skipping, inplace/mingw exists]) + return 0 + fi + local action if test "$TarballsAutodownload" = "NO" then @@ -17,6 +29,9 @@ AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[ else action="download" fi + readonly action + AC_MSG_RESULT([$action...]) + $PYTHON mk/get-win32-tarballs.py $action $mingw_arch case $? in 0) @@ -45,22 +60,19 @@ AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[ esac # Extract all the tarballs in one go - if ! test -d inplace/mingw - then - AC_MSG_NOTICE([Extracting Windows toolchain from archives (may take a while)...]) - rm -rf inplace/mingw - local base_dir="../ghc-tarballs/${tarball_dest_dir}" - ( cd inplace && - find "${base_dir}" -name "*.tar.xz" -exec tar --xz -xf {} \; && - find "${base_dir}" -name "*.tar.zst" -exec tar --zstd -xf {} \; && - rm ".MTREE" && - rm ".PKGINFO" && - cd .. ) || AC_MSG_ERROR([Could not extract Windows toolchains.]) - - mv "inplace/${tarball_mingw_dir}" inplace/mingw && - touch inplace/mingw - AC_MSG_NOTICE([In-tree MingW-w64 tree created]) - fi + AC_MSG_NOTICE([Extracting Windows toolchain from archives (may take a while)...]) + rm -rf inplace/mingw + local base_dir="../ghc-tarballs/${tarball_dest_dir}" + ( cd inplace && + find "${base_dir}" -name "*.tar.xz" -exec tar --xz -xf {} \; && + find "${base_dir}" -name "*.tar.zst" -exec tar --zstd -xf {} \; && + rm ".MTREE" && + rm ".PKGINFO" && + cd .. ) || AC_MSG_ERROR([Could not extract Windows toolchains.]) + + mv "inplace/${tarball_mingw_dir}" inplace/mingw && + touch inplace/mingw + AC_MSG_NOTICE([In-tree MingW-w64 tree created]) } # See Note [How we configure the bundled windows toolchain] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/49d94b1dcb8a161d3988f02d8ad4773… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/49d94b1dcb8a161d3988f02d8ad4773… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] Wibble
by Simon Peyton Jones (＠simonpj) 15 May '25

15 May '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: 76b01916 by Simon Peyton Jones at 2025-05-15T06:54:29-04:00 Wibble - - - - - 1 changed file: - compiler/GHC/Core/Opt/OccurAnal.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -1114,7 +1114,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl -- Precondition: Id is not a join point -mkNonRecRhsCtxt lvl bndr unf +mkNonRecRhsCtxt _lvl bndr unf | certainly_inline = OccVanilla -- See Note [Cascading inlines] | otherwise = OccRhs where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76b019160e730140ee0a51f0bf83896… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76b019160e730140ee0a51f0bf83896… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] Improvements
by Simon Peyton Jones (＠simonpj) 14 May '25

14 May '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: e1482394 by Simon Peyton Jones at 2025-05-14T23:21:36-04:00 Improvements esp inline top level things not-under-lambda only if it's a function. Beware extra iterations in T18698a - - - - - 2 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -1124,7 +1124,7 @@ mkNonRecRhsCtxt lvl bndr unf -- Distressing delicacy ... has to line up with preInlineUnconditionally case idOccInfo bndr of OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 } - -> active && not (isTopLevel lvl) && not stable_unf + -> active && not stable_unf _ -> False active = isAlwaysActive (idInlineActivation bndr) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1465,7 +1465,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env , occ_in_lam = NotInsideLam , occ_int_cxt = int_cxt } = isNotTopLevel top_lvl -- Get rid of allocation - || (int_cxt==IsInteresting) -- Function is applied + || (int_cxt==IsInteresting && idArity bndr > 0) -- Function is applied -- || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase one_occ OneOcc{ occ_n_br = 1 , occ_in_lam = IsInsideLam @@ -1632,6 +1632,7 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs unfolding = idUnfolding bndr -- arity = idArity bndr is_cheap = isCheapUnfolding unfolding + is_exp = isExpandableUnfolding unfolding uf_opts = seUnfoldingOpts env phase = sePhase env active = isActive phase (idInlineActivation bndr) @@ -1639,6 +1640,8 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs -- Check for code-size blow-up from inlining in multiple places code_dup_ok n_br + | is_top_lvl -- Don't inline top-level datacons, ever; no advantage, + , is_exp = False -- and float-out may have carefully created them | n_br == 1 = True -- No duplication | n_br >= 100 = False -- See #23627 | is_demanded = False -- Demanded => no allocation (it'll be a case expression View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e14823948401b7dad78cc4f2eddb03b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e14823948401b7dad78cc4f2eddb03b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out] debugger: Implement step-out feature
by Rodrigo Mesquita (＠alt-romes) 14 May '25

14 May '25

Rodrigo Mesquita pushed to branch wip/romes/step-out at Glasgow Haskell Compiler / GHC Commits: a043f051 by Rodrigo Mesquita at 2025-05-14T17:56:40+01:00 debugger: Implement step-out feature Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key implementation bit is simple: When step-out is set and the interpreter hits a RETURN instruction, enable "stop at the immediate next breakpoint" (aka single-step). See also `Note [Debugger Step-out]` in `rts/Interpreter.c` Note [Debugger Step-out] ~~~~~~~~~~~~~~~~~~~~~~~~ When the global debugger step-out flag is set (`rts_stop_after_return`), the interpreter must yield execution right after the first RETURN. When stepping-out, we simply enable `rts_stop_next_breakpoint` when we hit a return instruction (in `do_return_pointer` and `do_return_nonpointer`). The step-out flag is cleared and must be re-enabled explicitly to step-out again. A limitation of this approach is that stepping-out of a function that was tail-called will skip its caller since no stack frame is pushed for a tail call (i.e. a tail call returns directly to its caller's first non-tail caller). Fixes #26042 - - - - - 10 changed files: - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Interpreter.c - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -3,6 +3,7 @@ module GHC.Driver.Config ( initOptCoercionOpts , initSimpleOpts , initEvalOpts + , EvalStep(..) ) where @@ -28,13 +29,28 @@ initSimpleOpts dflags = SimpleOpts , so_inline = True } +-- | Instruct the interpreter evaluation to break... +data EvalStep + -- | ... at every breakpoint tick + = EvalStepSingle + -- | ... after every return stmt + | EvalStepOut + -- | ... only on explicit breakpoints + | EvalStepNone + -- | Extract GHCi options from DynFlags and step -initEvalOpts :: DynFlags -> Bool -> EvalOpts +initEvalOpts :: DynFlags -> EvalStep -> EvalOpts initEvalOpts dflags step = EvalOpts { useSandboxThread = gopt Opt_GhciSandbox dflags - , singleStep = step + , singleStep = singleStep + , stepOut = stepOut , breakOnException = gopt Opt_BreakOnException dflags , breakOnError = gopt Opt_BreakOnError dflags } + where + (singleStep, stepOut) = case step of + EvalStepSingle -> (True, False) + EvalStepOut -> (False, True) + EvalStepNone -> (False, False) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -343,7 +343,12 @@ handleRunStatus step expr bindings final_ids status history0 = do setSession hsc_env2 return (ExecBreak names Nothing) - -- Just case: we stopped at a breakpoint + -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint + -- + -- The interpreter yields on a breakpoint if: + -- - the breakpoint was explicitly enabled (in @BreakArray@) + -- - or @singleStep = True@ in EvalOpts + -- - or @stopAfterRet = True@ in EvalOpts EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do let ibi = evalBreakpointToId eval_break tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi) @@ -351,13 +356,14 @@ handleRunStatus step expr bindings final_ids status history0 = do span = modBreaks_locs tick_brks ! ibi_tick_index ibi decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi + -- Was the breakpoint explicitly enabled? b <- liftIO $ breakpointStatus interp (modBreaks_flags tick_brks) (ibi_tick_index ibi) apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt - -- This breakpoint is explicitly enabled; we want to stop - -- instead of just logging it. + -- This breakpoint is enabled or we mean to break here; + -- we want to stop instead of just logging it. if b || breakHere step span then do -- This function only returns control to ghci with 'ExecBreak' when it is really meant to break. -- Specifically, for :steplocal or :stepmodule, don't return control @@ -1247,7 +1253,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do _ -> panic "compileParsedExprRemote" updateFixityEnv fix_env - let eval_opts = initEvalOpts dflags False + let eval_opts = initEvalOpts dflags EvalStepNone status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) case status of EvalComplete _ (EvalSuccess [hval]) -> return hval ===================================== compiler/GHC/Runtime/Eval/Types.hs ===================================== @@ -17,6 +17,7 @@ import GHC.Prelude import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) +import GHC.Driver.Config (EvalStep(..)) import GHC.Types.Id import GHC.Types.Name import GHC.Types.TyThing @@ -46,6 +47,9 @@ data SingleStep -- | :step [expr] | SingleStep + -- | :stepout [expr] + | StepOut + -- | :steplocal [expr] | LocalStep { breakAt :: SrcSpan } @@ -55,10 +59,12 @@ data SingleStep { breakAt :: SrcSpan } -- | Whether this 'SingleStep' mode requires instructing the interpreter to --- step at every breakpoint. -enableGhcStepMode :: SingleStep -> Bool -enableGhcStepMode RunToCompletion = False -enableGhcStepMode _ = True +-- step at every breakpoint or after every return (see @'EvalStep'@). +enableGhcStepMode :: SingleStep -> EvalStep +enableGhcStepMode RunToCompletion = EvalStepNone +enableGhcStepMode StepOut = EvalStepOut +-- for the remaining step modes we need to stop at every single breakpoint. +enableGhcStepMode _ = EvalStepSingle -- | Given a 'SingleStep' mode and the SrcSpan of a breakpoint we hit, return -- @True@ if based on the step-mode alone we should stop at this breakpoint. @@ -70,6 +76,7 @@ breakHere :: SingleStep -> SrcSpan -> Bool breakHere step break_span = case step of RunToCompletion -> False RunAndLogSteps -> False + StepOut -> True -- hmm. this function may not be a good abstraction? SingleStep -> True LocalStep span -> break_span `isSubspanOf` span ModuleStep span -> srcSpanFileName_maybe span == srcSpanFileName_maybe break_span ===================================== docs/users_guide/ghci.rst ===================================== @@ -2980,6 +2980,33 @@ commonly used commands. hit by an error (:ghc-flag:`-fbreak-on-error`) or an exception (:ghc-flag:`-fbreak-on-exception`). +.. ghci-cmd:: :stepout + + Stop at the first breakpoint immediately after returning from the current + function scope. + + Known limitations: because a function tail-call does not push a stack + frame, if step-out is used inside of a function that was tail-called, + execution will not be returned to its caller, but rather its caller's + first non-tail caller. In the following example: + + .. code-block:: none + + f = do + a + b <--- (1) set breakpoint then step in here + c + b = do + ... + d <--- (2) step-into this tail call + d = do + ... + something <--- (3) step-out here + ... + + Stepping-out will stop execution at the `c` invokation in `f`, rather than + stopping at `b`. + .. ghci-cmd:: :stepmodule Enable only breakpoints in the current module and resume evaluation ===================================== ghc/GHCi/UI.hs ===================================== @@ -247,6 +247,7 @@ ghciCommands = map mkCmd [ ("sprint", keepGoing sprintCmd, completeExpression), ("step", keepGoing stepCmd, completeIdentifier), ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepout", keepGoing stepOutCmd, completeIdentifier), ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), ("type", keepGoingMulti' typeOfExpr, completeExpression), ("trace", keepGoing traceCmd, completeExpression), @@ -407,6 +408,7 @@ defFullHelpText = " :step single-step after stopping at a breakpoint\n"++ " :step <expr> single-step into <expr>\n"++ " :steplocal single-step within the current top-level binding\n"++ + " :stepout stop at the first breakpoint after returning from the current scope\n"++ " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++ @@ -3793,6 +3795,12 @@ stepCmd arg = withSandboxOnly ":step" $ step arg step [] = doContinue GHC.SingleStep step expression = runStmt expression GHC.SingleStep >> return () +stepOutCmd :: GhciMonad m => String -> m () +stepOutCmd arg = withSandboxOnly ":stepout" $ step arg + where + step [] = doContinue GHC.StepOut + step expression = stepCmd expression + stepLocalCmd :: GhciMonad m => String -> m () stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg where ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -374,6 +374,7 @@ putTHMessage m = case m of data EvalOpts = EvalOpts { useSandboxThread :: Bool , singleStep :: Bool + , stepOut :: Bool , breakOnException :: Bool , breakOnError :: Bool } ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -210,6 +210,7 @@ evalOptsSeq :: EvalOpts evalOptsSeq = EvalOpts { useSandboxThread = True , singleStep = False + , stepOut = False , breakOnException = False , breakOnError = False } @@ -333,6 +334,7 @@ withBreakAction opts breakMVar statusMVar act poke breakPointIOAction stablePtr when (breakOnException opts) $ poke exceptionFlag 1 when (singleStep opts) $ setStepFlag + when (breakOnException opts) $ poke stepOutFlag 1 return stablePtr -- Breaking on exceptions is not enabled by default, since it -- might be a bit surprising. The exception flag is turned off @@ -363,6 +365,7 @@ withBreakAction opts breakMVar statusMVar act resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr poke exceptionFlag 0 + poke stepOutFlag 0 resetStepFlag freeStablePtr stablePtr @@ -398,6 +401,7 @@ abandonStmt hvref = do foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt +foreign import ccall "&rts_stop_after_return" stepOutFlag :: Ptr CInt setStepFlag :: IO () setStepFlag = poke stepFlag 1 ===================================== rts/Interpreter.c ===================================== @@ -194,6 +194,24 @@ See also Note [Width of parameters] for some more motivation. #define WITHIN_CHUNK_BOUNDS(n, s) \ (RTS_LIKELY((StgWord*)(Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame)))) +// Note [Debugger Step-out] +// ~~~~~~~~~~~~~~~~~~~~~~~~ +// When the global debugger step-out flag is set (`rts_stop_after_return`), +// the interpreter must yield execution right after the first RETURN. +// +// When stepping-out, we simply enable `rts_stop_next_breakpoint` when we hit a +// return instruction (in `do_return_pointer` and `do_return_nonpointer`). +// The step-out flag is cleared and must be re-enabled explicitly to step-out again. +// +// A limitation of this approach is that stepping-out of a function that was +// tail-called will skip its caller since no stack frame is pushed for a tail +// call (i.e. a tail call returns directly to its caller's first non-tail caller). +#define CHECK_BRK_AFTER_RET() \ + if (rts_stop_after_return) \ + { \ + rts_stop_next_breakpoint = true; \ + rts_stop_after_return = false; \ + } \ /* Note [PUSH_L underflow] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -245,6 +263,7 @@ allocate_NONUPD (Capability *cap, int n_words) int rts_stop_next_breakpoint = 0; int rts_stop_on_exception = 0; +int rts_stop_after_return = 0; #if defined(INTERP_STATS) @@ -734,6 +753,8 @@ do_return_pointer: IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size)); + CHECK_BRK_AFTER_RET(); + switch (get_itbl((StgClosure *)Sp)->type) { case RET_SMALL: { @@ -883,6 +904,8 @@ do_return_nonpointer: // get the offset of the header of the next stack frame offset = stack_frame_sizeW((StgClosure *)Sp); + CHECK_BRK_AFTER_RET(); + switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) { case RET_BCO: ===================================== rts/RtsSymbols.c ===================================== @@ -908,6 +908,7 @@ extern char **environ; SymI_NeedsDataProto(rts_breakpoint_io_action) \ SymI_NeedsDataProto(rts_stop_next_breakpoint) \ SymI_NeedsDataProto(rts_stop_on_exception) \ + SymI_NeedsDataProto(rts_stop_after_return) \ SymI_HasProto(stopTimer) \ SymI_HasProto(n_capabilities) \ SymI_HasProto(max_n_capabilities) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -619,6 +619,7 @@ RTS_FUN_DECL(stg_castFloatToWord32zh); // Interpreter.c extern StgWord rts_stop_next_breakpoint[]; extern StgWord rts_stop_on_exception[]; +extern StgWord rts_stop_after_return[]; extern StgWord rts_breakpoint_io_action[]; // Schedule.c View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a043f05102cb9357e58c30cb1a2cbb9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a043f05102cb9357e58c30cb1a2cbb9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/romes/step-out
by Rodrigo Mesquita (＠alt-romes) 14 May '25

14 May '25

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

1 0

[Git][ghc/ghc][wip/fendor/ann-frame] Annotate frame
by Hannes Siebenhandl (＠fendor) 14 May '25

14 May '25

Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: 1dd1bff4 by Ben Gamari at 2025-05-14T17:19:40+02:00 Annotate frame - - - - - 25 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/StgToCmm/Prim.hs - libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Stack.hs - libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - libraries/ghc-heap/tests/all.T - + libraries/ghc-heap/tests/ann_frame.hs - libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs - rts/ClosureFlags.c - rts/LdvProfile.c - rts/PrimOps.cmm - rts/Printer.c - rts/RetainerProfile.c - rts/TraverseHeap.c - rts/include/rts/storage/ClosureTypes.h - rts/include/rts/storage/Closures.h - rts/js/profiling.js - rts/sm/Compact.c - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Sanity.c - rts/sm/Scav.c - utils/deriveConstants/Main.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3927,6 +3927,16 @@ primop ClearCCSOp "clearCCS#" GenPrimOp with out_of_line = True +------------------------------------------------------------------------ +section "Annotating call stacks" +------------------------------------------------------------------------ + +primop AnnotateStackOp "annotateStack#" GenPrimOp + b -> a_reppoly -> a_reppoly + { Pushes an annotation frame to the stack which can be reported by backtraces. } + with + out_of_line = True + ------------------------------------------------------------------------ section "Info Table Origin" ------------------------------------------------------------------------ ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1771,6 +1771,7 @@ emitPrimOp cfg primop = WhereFromOp -> alwaysExternal GetApStackValOp -> alwaysExternal ClearCCSOp -> alwaysExternal + AnnotateStackOp -> alwaysExternal TraceEventOp -> alwaysExternal TraceEventBinaryOp -> alwaysExternal TraceMarkerOp -> alwaysExternal ===================================== libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs ===================================== @@ -84,6 +84,7 @@ data ClosureType | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN | COMPACT_NFDATA | CONTINUATION + | ANN_FRAME | N_CLOSURE_TYPES deriving (Enum, Eq, Ord, Show, Generic) #endif ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -574,11 +574,15 @@ data GenStackFrame b = , retFunPayload :: ![GenStackField b] } - | RetBCO + | RetBCO { info_tbl :: !StgInfoTable , bco :: !b -- ^ always a BCOClosure , bcoArgs :: ![GenStackField b] } + | AnnFrame + { info_tbl :: !StgInfoTable + , annotation :: !b + } deriving (Foldable, Functor, Generic, Show, Traversable) data PrimType ===================================== libraries/ghc-heap/GHC/Exts/Stack.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if MIN_TOOL_VERSION_ghc(9,9,0) +#if MIN_TOOL_VERSION_ghc(9,13,0) {-# LANGUAGE RecordWildCards #-} module GHC.Exts.Stack @@ -30,6 +30,7 @@ stackFrameSize (RetFun {..}) = sizeStgRetFunFrame + length retFunPayload stackFrameSize (RetBCO {..}) = sizeStgClosure + 1 + length bcoArgs -- The one additional word is a pointer to the next stack chunk stackFrameSize (UnderflowFrame {}) = sizeStgClosure + 1 +stackFrameSize (AnnFrame {}) = sizeStgAnnFrame stackFrameSize _ = error "Unexpected stack frame type" #else ===================================== libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc ===================================== @@ -3,7 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Exts.Stack.Constants where -#if MIN_TOOL_VERSION_ghc(9,9,0) +#if MIN_TOOL_VERSION_ghc(9,13,0) import Prelude @@ -88,6 +88,13 @@ offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_pa sizeStgRetFunFrame :: Int sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun) +sizeStgAnnFrame :: Int +sizeStgAnnFrame = bytesToWords (#const SIZEOF_StgAnnFrame) + +offsetStgAnnFrameAnn :: WordOffset +offsetStgAnnFrameAnn = byteOffsetToWordOffset $ + (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader) + offsetStgBCOFrameInstrs :: ByteOffset offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader) ===================================== libraries/ghc-heap/GHC/Exts/Stack/Decode.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if MIN_TOOL_VERSION_ghc(9,9,0) +#if MIN_TOOL_VERSION_ghc(9,13,0) {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} @@ -377,6 +377,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do catchFrameCode = catchFrameCode', handler = handler' } + ANN_FRAME -> + let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) + in + pure $ + AnnFrame + { info_tbl = info, + annotation = annotation + } x -> error $ "Unexpected closure type on stack: " ++ show x -- | Unbox 'Int#' from 'Int' ===================================== libraries/ghc-heap/tests/all.T ===================================== @@ -103,3 +103,5 @@ test('stack_misc_closures', ] , '-debug' # Debug RTS to use checkSTACK() (Sanity.c) ]) + +test('ann_frame', normal, compile_and_run, ['']) ===================================== libraries/ghc-heap/tests/ann_frame.hs ===================================== @@ -0,0 +1,36 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE GADTs #-} + +import Data.Typeable +import GHC.Exts +import GHC.Exts.Heap.Closures as Closures +import GHC.Exts.Stack.Decode +import GHC.Stack.CloneStack +import System.IO.Unsafe +import Unsafe.Coerce + +data StackAnnotation where + StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation + +annotateStack + :: forall a r b. + (Typeable a, Show a) + => a -> b -> b +annotateStack ann = + annotateStack# (StackAnnotation ann) + +hello :: Int -> Int -> Int +hello x y = annotateStack (x,y) $ unsafePerformIO $ do + stack <- GHC.Stack.CloneStack.cloneMyStack + decoded <- GHC.Exts.Stack.Decode.decodeStack stack + print [ show x + | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded + , StackAnnotation x <- pure $ unsafeCoerce ann + ] + return $ x + y + 42 +{-# OPAQUE hello #-} + +main :: IO () +main = + print $ hello 2 3 + ===================================== libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs ===================================== @@ -83,5 +83,6 @@ data ClosureType | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN | COMPACT_NFDATA | CONTINUATION + | ANN_FRAME | N_CLOSURE_TYPES deriving (Enum, Eq, Ord, Show, Generic) ===================================== rts/ClosureFlags.c ===================================== @@ -88,8 +88,9 @@ const StgWord16 closure_flags[] = { [SMALL_MUT_ARR_PTRS_FROZEN_CLEAN] = (_HNF| _NS| _UPT ), [COMPACT_NFDATA] = (_HNF| _NS ), [CONTINUATION] = (_HNF| _NS| _UPT ), + [ANN_FRAME] = ( _BTM| _FRM ), }; -#if N_CLOSURE_TYPES != 65 +#if N_CLOSURE_TYPES != 66 #error Closure types changed: update ClosureFlags.c! #endif ===================================== rts/LdvProfile.c ===================================== @@ -154,6 +154,7 @@ processHeapClosureForDead( const StgClosure *c ) case CATCH_STM_FRAME: case CATCH_RETRY_FRAME: case ATOMICALLY_FRAME: + case ANN_FRAME: // others case INVALID_OBJECT: case COMPACT_NFDATA: ===================================== rts/PrimOps.cmm ===================================== @@ -2800,6 +2800,28 @@ stg_clearCCSzh (P_ arg) jump stg_ap_v_fast(arg); } +#define ANN_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,ann) \ + w_ info_ptr, \ + PROF_HDR_FIELDS(w_,p1,p2) \ + p_ ann + +INFO_TABLE_RET (stg_ann_frame, ANN_FRAME, + ANN_FRAME_FIELDS(W_,P_, info_ptr, p1, p2, ann)) + /* no args => explicit stack */ +{ + unwind Sp = W_[Sp + SIZEOF_StgAnnFrame]; + Sp = Sp + SIZEOF_StgAnnFrame; + jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live! +} + +stg_annotateStackzh (P_ ann, P_ cont) +{ + STK_CHK_GEN(); + jump stg_ap_0_fast + (ANN_FRAME_FIELDS(,,stg_ann_frame_info, CCCS, 0, ann))(cont); + +} + stg_numSparkszh () { W_ n; ===================================== rts/Printer.c ===================================== @@ -270,6 +270,17 @@ printClosure( const StgClosure *obj ) case RET_FUN: */ + case ANN_FRAME: + { + StgAnnFrame* frame = (StgAnnFrame*)obj; + debugBelch("ANN_FRAME("); + printPtr((StgPtr)GET_INFO((StgClosure *)frame)); + debugBelch(","); + printPtr((StgPtr)frame->ann); + debugBelch(")\n"); + break; + } + case UPDATE_FRAME: { StgUpdateFrame* frame = (StgUpdateFrame*)obj; @@ -1123,6 +1134,7 @@ const char *closure_type_names[] = { [RET_FUN] = "RET_FUN", [UPDATE_FRAME] = "UPDATE_FRAME", [CATCH_FRAME] = "CATCH_FRAME", + [ANN_FRAME] = "ANN_FRAME", [UNDERFLOW_FRAME] = "UNDERFLOW_FRAME", [STOP_FRAME] = "STOP_FRAME", [BLOCKING_QUEUE] = "BLOCKING_QUEUE", @@ -1155,7 +1167,7 @@ const char *closure_type_names[] = { [CONTINUATION] = "CONTINUATION", }; -#if N_CLOSURE_TYPES != 65 +#if N_CLOSURE_TYPES != 66 #error Closure types changed: update Printer.c! #endif ===================================== rts/RetainerProfile.c ===================================== @@ -217,6 +217,7 @@ isRetainer( const StgClosure *c ) case RET_SMALL: case RET_BIG: case RET_FUN: + case ANN_FRAME: // other cases case IND: case INVALID_OBJECT: ===================================== rts/TraverseHeap.c ===================================== @@ -529,6 +529,7 @@ traverseGetChildren(StgClosure *c, StgClosure **first_child, bool *other_childre case RET_BCO: case RET_SMALL: case RET_BIG: + case ANN_FRAME: // invalid objects case IND: case INVALID_OBJECT: @@ -832,6 +833,7 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data, case RET_BCO: case RET_SMALL: case RET_BIG: + case ANN_FRAME: // invalid objects case IND: case INVALID_OBJECT: @@ -965,6 +967,7 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackElement *sep, case CATCH_RETRY_FRAME: case ATOMICALLY_FRAME: case RET_SMALL: + case ANN_FRAME: bitmap = BITMAP_BITS(info->i.layout.bitmap); size = BITMAP_SIZE(info->i.layout.bitmap); p++; ===================================== rts/include/rts/storage/ClosureTypes.h ===================================== @@ -89,4 +89,5 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA 63 #define CONTINUATION 64 -#define N_CLOSURE_TYPES 65 +#define ANN_FRAME 65 +#define N_CLOSURE_TYPES 66 ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -312,6 +312,15 @@ typedef struct { StgClosure *result; } StgDeadThreadFrame; +// Stack frame annotating an execution context with a Haskell value +// for backtrace purposes. +// +// Closure types: ANN_FRAME +typedef struct { + StgHeader header; + StgClosure *ann; +} StgAnnFrame; + // A function return stack frame: used when saving the state for a // garbage collection at a function entry point. The function // arguments are on the stack, and we also save the function (its ===================================== rts/js/profiling.js ===================================== @@ -333,3 +333,8 @@ function h$buildCCSPtr(o) { function h$clearCCS(a) { throw new Error("ClearCCSOp not implemented"); } + +// we throw away the annotation here. +function h$annotateStack(o) { + return o; +} ===================================== rts/sm/Compact.c ===================================== @@ -351,6 +351,7 @@ thread_stack(P_ p, P_ stack_end) case STOP_FRAME: case CATCH_FRAME: case RET_SMALL: + case ANN_FRAME: { W_ bitmap = BITMAP_BITS(info->i.layout.bitmap); W_ size = BITMAP_SIZE(info->i.layout.bitmap); ===================================== rts/sm/Evac.c ===================================== @@ -996,6 +996,7 @@ loop: case CATCH_STM_FRAME: case CATCH_RETRY_FRAME: case ATOMICALLY_FRAME: + case ANN_FRAME: // shouldn't see these barf("evacuate: stack frame at %p\n", q); ===================================== rts/sm/NonMovingMark.c ===================================== @@ -1180,6 +1180,7 @@ trace_stack_ (MarkQueue *queue, StgPtr sp, StgPtr spBottom) case STOP_FRAME: case CATCH_FRAME: case RET_SMALL: + case ANN_FRAME: { StgWord bitmap = BITMAP_BITS(info->i.layout.bitmap); StgWord size = BITMAP_SIZE(info->i.layout.bitmap); ===================================== rts/sm/Sanity.c ===================================== @@ -128,6 +128,7 @@ checkStackFrame( StgPtr c ) case UNDERFLOW_FRAME: case STOP_FRAME: case RET_SMALL: + case ANN_FRAME: size = BITMAP_SIZE(info->i.layout.bitmap); checkSmallBitmap((StgPtr)c + 1, BITMAP_BITS(info->i.layout.bitmap), size); ===================================== rts/sm/Scav.c ===================================== @@ -1983,6 +1983,7 @@ scavenge_stack(StgPtr p, StgPtr stack_end) case STOP_FRAME: case CATCH_FRAME: case RET_SMALL: + case ANN_FRAME: bitmap = BITMAP_BITS(info->i.layout.bitmap); size = BITMAP_SIZE(info->i.layout.bitmap); // NOTE: the payload starts immediately after the info-ptr, we ===================================== utils/deriveConstants/Main.hs ===================================== @@ -443,6 +443,8 @@ wanteds os = concat ,closureSize C "StgStopFrame" ,closureSize C "StgDeadThreadFrame" ,closureField C "StgDeadThreadFrame" "result" + ,structSize C "StgAnnFrame" + ,closureField C "StgAnnFrame" "ann" ,closureSize Both "StgMutArrPtrs" ,closureField Both "StgMutArrPtrs" "ptrs" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd1bff4867f2ca3c7863d4d5aa7bda… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd1bff4867f2ca3c7863d4d5aa7bda… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T18570] Calculate multiplicity for record selector functions
by Sjoerd Visscher (＠trac-sjoerd_visscher) 14 May '25

14 May '25

Sjoerd Visscher pushed to branch wip/T18570 at Glasgow Haskell Compiler / GHC Commits: f4cf1a54 by Sjoerd Visscher at 2025-05-14T16:25:51+02:00 Calculate multiplicity for record selector functions Until now record selector functions always had multiplicity Many, but when all the other fields have been declared with multiplicity Many (including the case when there are no other fields), then the selector function is allowed to be used linearly too, as it is allowed to discard all the other fields. Since in that case the multiplicity can be both One and Many, the selector function is made multiplicity-polymorphic. - - - - - 9 changed files: - compiler/GHC/Core/DataCon.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - docs/users_guide/9.14.1-notes.rst - + testsuite/tests/linear/should_compile/LinearRecordSelector.hs - testsuite/tests/linear/should_compile/all.T - + testsuite/tests/linear/should_fail/LinearRecordSelectorFail.hs - + testsuite/tests/linear/should_fail/LinearRecordSelectorFail.stderr - testsuite/tests/linear/should_fail/all.T Changes: ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -44,6 +44,7 @@ module GHC.Core.DataCon ( dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs, dataConInstUnivs, dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, + dataConOtherFieldsAllMultMany, dataConSrcBangs, dataConSourceArity, dataConRepArity, dataConIsInfix, @@ -1405,6 +1406,15 @@ dataConFieldType_maybe :: DataCon -> FieldLabelString dataConFieldType_maybe con label = find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con)) +-- | Check if all the fields of the 'DataCon' have multiplicity 'Many', +-- except for the given labelled field. In this case the selector +-- of the given field can be a linear function, since it is allowed +-- to discard all the other fields. +dataConOtherFieldsAllMultMany :: DataCon -> FieldLabelString -> Bool +dataConOtherFieldsAllMultMany con label + = all (\(fld, mult) -> flLabel fld == label || isManyTy mult) + (dcFields con `zip` (scaledMult <$> dcOrigArgTys con)) + -- | Strictness/unpack annotations, from user; or, for imported -- DataCons, from the interface file -- The list is in one-to-one correspondence with the arity of the 'DataCon' ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -841,7 +841,7 @@ mkPatSynRecSelBinds :: PatSyn -> FieldSelectors -> [(Id, LHsBind GhcRn)] mkPatSynRecSelBinds ps fields has_sel - = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel + = [ mkOneRecordSelector True [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel | fld_lbl <- fields ] isUnidirectional :: HsPatSynDir a -> Bool ===================================== compiler/GHC/Tc/TyCl/Utils.hs ===================================== @@ -32,7 +32,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds ) import GHC.Tc.Utils.TcType -import GHC.Builtin.Types( unitTy ) +import GHC.Builtin.Types( unitTy, manyDataConTy, multiplicityTy ) import GHC.Builtin.Uniques ( mkBuiltinUnique ) import GHC.Hs @@ -71,6 +71,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Reader ( mkRdrUnqual ) import GHC.Types.Id import GHC.Types.Id.Info +import GHC.Types.Var (mkTyVar) import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Unique.Set @@ -765,7 +766,8 @@ addTyConsToGblEnv tyclss do { traceTc "tcAddTyCons" $ vcat [ text "tycons" <+> ppr tyclss , text "implicits" <+> ppr implicit_things ] - ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) + ; linearEnabled <- xoptM LangExt.LinearTypes + ; gbl_env <- tcRecSelBinds (mkRecSelBinds linearEnabled tyclss) ; th_bndrs <- tcTyThBinders implicit_things ; return (gbl_env, th_bndrs) } @@ -848,24 +850,24 @@ tcRecSelBinds sel_bind_prs , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, [bind]) | (_, bind) <- sel_bind_prs] -mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] +mkRecSelBinds :: Bool -> [TyCon] -> [(Id, LHsBind GhcRn)] -- NB We produce *un-typechecked* bindings, rather like 'deriving' -- This makes life easier, because the later type checking will add -- all necessary type abstractions and applications -mkRecSelBinds tycons - = map mkRecSelBind [ (tc,fld) | tc <- tycons - , fld <- tyConFieldLabels tc ] +mkRecSelBinds allowMultiplicity tycons + = [ mkRecSelBind allowMultiplicity tc fld | tc <- tycons + , fld <- tyConFieldLabels tc ] -mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) -mkRecSelBind (tycon, fl) - = mkOneRecordSelector all_cons (RecSelData tycon) fl +mkRecSelBind :: Bool -> TyCon -> FieldLabel -> (Id, LHsBind GhcRn) +mkRecSelBind allowMultiplicity tycon fl + = mkOneRecordSelector allowMultiplicity all_cons (RecSelData tycon) fl FieldSelectors -- See Note [NoFieldSelectors and naughty record selectors] where all_cons = map RealDataCon (tyConDataCons tycon) -mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors +mkOneRecordSelector :: Bool -> [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors -> (Id, LHsBind GhcRn) -mkOneRecordSelector all_cons idDetails fl has_sel +mkOneRecordSelector allowMultiplicity all_cons idDetails fl has_sel = (sel_id, L (noAnnSrcSpan loc) sel_bind) where loc = getSrcSpan sel_name @@ -916,17 +918,23 @@ mkOneRecordSelector all_cons idDetails fl has_sel -- thus suppressing making a binding -- A slight hack! + all_other_fields_unrestricted = all all_other_unrestricted all_cons + where + all_other_unrestricted PatSynCon{} = False + all_other_unrestricted (RealDataCon dc) = dataConOtherFieldsAllMultMany dc lbl + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkForAllTys (tyVarSpecToBinders sel_tvbs) $ + | otherwise = mkForAllTys (tyVarSpecToBinders (sel_tvbs ++ mult_tvb)) $ -- Urgh! See Note [The stupid context] in GHC.Core.DataCon - mkPhiTy (conLikeStupidTheta con1) $ + mkPhiTy (conLikeStupidTheta con1) $ -- req_theta is empty for normal DataCon - mkPhiTy req_theta $ - mkVisFunTyMany data_ty $ - -- Record selectors are always typed with Many. We - -- could improve on it in the case where all the - -- fields in all the constructor have multiplicity Many. + mkPhiTy req_theta $ + mkVisFunTy sel_mult data_ty $ field_ty + (mult_tvb, sel_mult) = if allowMultiplicity && all_other_fields_unrestricted + then ([mkForAllTyBinder InferredSpec mult_var], mkTyVarTy mult_var) + else ([], manyDataConTy) + mult_var = mkTyVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "m")) multiplicityTy -- make the binding: sel (C2 { fld = x }) = x -- sel (C7 { fld = x }) = x ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -67,6 +67,11 @@ Language This causes the constructor to have type ``Rec :: Int %'Many -> Char %1 -> Record``. + Also record selector functions are now multiplicity-polymorphic when possible. + In the above example the selector function ``y`` now has type + ``y :: Record %m -> Char``, because the ``x`` field is allowed to be discarded. + In particular this applies to the selector of a newtype wrapper. + * The :extension:`MonadComprehensions` extension now implies :extension:`ParallelListComp` as was originally intended (see `Monad Comprehensions <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/monad_comprehension…>`_). Compiler ===================================== testsuite/tests/linear/should_compile/LinearRecordSelector.hs ===================================== @@ -0,0 +1,25 @@ +{-# LANGUAGE LinearTypes, DataKinds, OverloadedRecordDot, RebindableSyntax #-} +module LinearRecordSelector where + +import GHC.Exts (Multiplicity(..)) +import Prelude + +getField :: () +getField = () + +data Test = A { test :: Int, test2 %Many :: String } | B { test %Many :: Int, test3 %Many :: Char } + +test1 :: Test %1 -> Int +test1 a = test a + +testM :: Test -> Int +testM a = test a + +testX :: Test %m -> Int +testX = test + +newtype NT = NT { unNT :: Int } + +nt :: NT %m -> Int +nt a = unNT a + ===================================== testsuite/tests/linear/should_compile/all.T ===================================== @@ -36,6 +36,7 @@ test('LinearTH3', normal, compile, ['']) test('LinearTH4', req_th, compile, ['']) test('LinearHole', normal, compile, ['']) test('LinearDataConSections', normal, compile, ['']) +test('LinearRecordSelector', normal, compile, ['-dcore-lint']) test('T18731', normal, compile, ['']) test('T19400', unless(compiler_debugged(), skip), compile, ['']) test('T20023', normal, compile, ['']) ===================================== testsuite/tests/linear/should_fail/LinearRecordSelectorFail.hs ===================================== @@ -0,0 +1,20 @@ +{-# LANGUAGE LinearTypes, DataKinds, OverloadedRecordDot, RebindableSyntax #-} +module LinearRecordSelector where + +import GHC.Exts (Multiplicity(..)) +import Prelude + +getField :: () +getField = () + +data Test1 = A1 { testA11 :: Int, testA12 :: String } + +-- Fails because testA12 is linear +test1 :: Test1 %1 -> Int +test1 a = testA11 a + +data Test2 = A2 { testA2 :: Int } | B2 { testB2 %Many :: Char } + +-- Fails because testA2 is partial +test2 :: Test2 %1 -> Int +test2 a = testA2 a \ No newline at end of file ===================================== testsuite/tests/linear/should_fail/LinearRecordSelectorFail.stderr ===================================== @@ -0,0 +1,10 @@ +LinearRecordSelectorFail.hs:14:7: error: [GHC-18872] + • Couldn't match type ‘Many’ with ‘One’ + arising from multiplicity of ‘a’ + • In an equation for ‘test1’: test1 a = testA11 a + +LinearRecordSelectorFail.hs:20:7: error: [GHC-18872] + • Couldn't match type ‘Many’ with ‘One’ + arising from multiplicity of ‘a’ + • In an equation for ‘test2’: test2 a = testA2 a + ===================================== testsuite/tests/linear/should_fail/all.T ===================================== @@ -11,6 +11,7 @@ test('LinearNoExt', normal, compile_fail, ['']) test('LinearNoExtU', normal, compile_fail, ['']) test('LinearAsPat', normal, compile_fail, ['']) test('LinearLazyPat', normal, compile_fail, ['']) +test('LinearRecordSelectorFail', normal, compile_fail, ['']) test('LinearRecordUpdate', normal, compile_fail, ['']) test('LinearSeq', normal, compile_fail, ['']) test('LinearViewPattern', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4cf1a54d50ecdd8b8b9e0ad944fb55… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4cf1a54d50ecdd8b8b9e0ad944fb55… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/ann-frame
by Hannes Siebenhandl (＠fendor) 14 May '25

14 May '25

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

1 0

[Git][ghc/ghc][wip/T25716] configure: Drop probing of ld.gold
by Ben Gamari (＠bgamari) 14 May '25

14 May '25

Ben Gamari pushed to branch wip/T25716 at Glasgow Haskell Compiler / GHC Commits: 5f0364e1 by Ben Gamari at 2025-05-14T10:12:03-04:00 configure: Drop probing of ld.gold As noted in #25716, `gold` has been dropped from binutils-2.44. - - - - - 1 changed file: - m4/find_ld.m4 Changes: ===================================== m4/find_ld.m4 ===================================== @@ -21,14 +21,7 @@ AC_DEFUN([FIND_LD],[ return fi - case $CPU in - i386) - # We refuse to use ld.gold on i386 due to #23579, which we don't - # have a good autoconf check for. - linkers="ld.lld ld" ;; - *) - linkers="ld.lld ld.gold ld" ;; - esac + linkers="ld.lld ld" # Manually iterate over possible names since we want to ensure that, e.g., # if ld.lld is installed but gcc doesn't support -fuse-ld=lld, that we View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f0364e190e1bfd5e1922791ede68dc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f0364e190e1bfd5e1922791ede68dc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 4 commits: Add testcases for GHCi multiple home units
by Hannes Siebenhandl (＠fendor) 14 May '25

14 May '25

Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC Commits: 41e4b50c by fendor at 2025-05-14T16:06:15+02:00 Add testcases for GHCi multiple home units Adds the following testcases: * Evaluate code with a single home unit using 'initMulti' initialisation logic * More complicated testcase with multiple home units, testing reload logic and code evaluation. - - - - - 67bde0c0 by fendor at 2025-05-14T16:06:15+02:00 FIXME: these test cases can be fixed by exploiting internals - - - - - 457194e9 by fendor at 2025-05-14T16:06:15+02:00 Make GHCi commands compatible with multiple home units === Design We enable all GHCi features that were previously guarded by the `inMulti` option. GHCi supported multiple home units up to a certain degree for quite a while now. The supported feature set was limited, due to a design impasse: One of the home units must be "active", e.g., there must be one `HomeUnit` whose `UnitId` is "active" which is returned when calling ```haskell do hscActiveUnitId <$> getSession ``` This makes sense in a GHC session, since you are always compiling a particular Module, but it makes less intuitive sense in an interactive session. Given an expression to evaluate, we can't easily tell in which "context" the expression should be parsed, typechecked and evaluated. That`s why initially, most of GHCi features, except for `:reload`ing were disabled if the GHCi session had more than one `HomeUnitEnv`. We lift this restriction, enabling all features of GHCi for the multiple home unit case. To do this, we fundamentally change the `HomeUnitEnv` graph to be multiple home unit first. Instead of differentiating the case were we have a single home unit and multiple, we now always set up a multiple home unit session that scales seamlessly to an arbitrary amount of home units. We introduce two new `HomeUnitEnv`s that are always added to the `HomeUnitGraph`. They are: The "interactive-ghci", called the `interactiveGhciUnit`, contains the same `DynFlags` that are used by the `InteractiveContext` for interactive evaluation of expressions. This `HomeUnitEnv` is only used on the prompt of GHCi, so we may refer to it as "interactive-prompt" unit. See Note [Relation between the `InteractiveContext` and `interactiveGhciUnitId`] for discussing its role. And the `interactive-session`, called `interactiveSessionUnit` or `interactiveSessionUnitId`, which is used for loading Scripts into GHCi that are not `Target`s of any home unit, via `:load` or `:add`. Both of these "interactive" home units depend on all other `HomeUnitEnv`s that are passed as arguments on the cli. Additionally, the "interactive-ghci" unit depends on `interactive-session`. We always evaluate expressions in the context of the "interactive-ghci" session. Since "interactive-ghci" depends on all home units, we can import any `Module` from the other home units with ease. As we have a clear `HomeUnitGraph` hierarchy, we can set `interactiveGhciUnitId` as the active home unit for the full duration of the GHCi session. In GHCi, we always set `interactiveGhciUnitId` to be the currently active home unit. === Implementation Details Given this design idea, the implementation is relatively straight forward. The core insight is that a `ModuleName` is not sufficient to identify a `Module` in the `HomeUnitGraph`. Thus, large parts of the PR is simply about refactoring usages of `ModuleName` to prefer `Module`, which has a `Unit` attached and is unique over the `HomeUnitGraph`. Consequentially, most usages of `lookupHPT` are likely to be incorrect and have been replaced by `lookupHugByModule` which is keyed by a `Module`. In `GHCi/UI.hs`, we make sure there is only one location where we are actually translating `ModuleName` to a `Module`: * `lookupQualifiedModuleName` If a `ModuleName` is ambiguous, we detect this and report it to the user. To avoid repeated lookups of `ModuleName`s, we store the `Module` in the `InteractiveImport`, which additionally simplifies the interface loading. A subtle detail is that the `DynFlags` of the `InteractiveContext` are now stored both in the `HomeUnitGraph` and in the `InteractiveContext`. In UI.hs, there are multiple code paths where we are careful to update the `DynFlags` in both locations. Most importantly in `addToProgramDynFlags`. --- There is one metric increase in this commit: ------------------------- Metric Increase: T4029 ------------------------- It is an increase from 14.4 MB to 16.1 MB (+11.8%) which sounds like a pretty big regression at first. However, we argue this increase is solely caused by using more data structures for managing multiple home units in the GHCi session. In particular, due to the design decision of using three home units, the base memory usage increases... but by how much? A big contributor is the `UnitState`, of which we have three now, which on its own 260 KB per instance. That makes an additional memory usage of 520 KB, already explaining a third of the overall memory usage increase. Then we store more elements in the `HomeUnitGraph`, we have more `HomeUnitEnv` entries, etc... While we didn't chase down each byte, we looked at the memory usage over time for both `-hi` and `-hT` profiles and can say with confidence while the memory usage increased slightly, we did not introduce any space leak, as the graph looks almost identical as the memory usage graph of GHC HEAD. - - - - - c3f0c498 by fendor at 2025-05-14T16:06:15+02:00 FIXUP: Multiple Home Units is no longer a special case - - - - - 125 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Types.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - ghc/GHCi/UI/Info.hs - ghc/GHCi/UI/Monad.hs - ghc/Main.hs - testsuite/driver/testlib.py - testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout - testsuite/tests/driver/T8526/T8526.stdout - testsuite/tests/driver/fat-iface/fat014.stdout - testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr - testsuite/tests/ghc-api/T6145.hs - testsuite/tests/ghc-api/annotations-literals/literals.hs - testsuite/tests/ghc-api/annotations-literals/parsed.hs - testsuite/tests/ghc-api/apirecomp001/myghc.hs - testsuite/tests/ghc-api/fixed-nodes/T1.hs - + testsuite/tests/ghci.debugger/scripts/break031/Makefile - + testsuite/tests/ghci.debugger/scripts/break031/a/A.hs - + testsuite/tests/ghci.debugger/scripts/break031/all.T - + testsuite/tests/ghci.debugger/scripts/break031/b/B.hs - + testsuite/tests/ghci.debugger/scripts/break031/break031a.script - + testsuite/tests/ghci.debugger/scripts/break031/break031a.stdout - + testsuite/tests/ghci.debugger/scripts/break031/break031b.script - + testsuite/tests/ghci.debugger/scripts/break031/break031b.stderr - + testsuite/tests/ghci.debugger/scripts/break031/break031b.stdout - + testsuite/tests/ghci.debugger/scripts/break031/unitA - + testsuite/tests/ghci.debugger/scripts/break031/unitB - testsuite/tests/ghci/linking/dyn/T3372.hs - + testsuite/tests/ghci/prog-mhu001/Makefile - + testsuite/tests/ghci/prog-mhu001/all.T - + testsuite/tests/ghci/prog-mhu001/e/E.hs - + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.stdout - + testsuite/tests/ghci/prog-mhu001/unitE - + testsuite/tests/ghci/prog-mhu001/unitE-main-is - + testsuite/tests/ghci/prog-mhu002/Makefile - + testsuite/tests/ghci/prog-mhu002/a/A.hs - + testsuite/tests/ghci/prog-mhu002/all.T - + testsuite/tests/ghci/prog-mhu002/b/B.hs - + testsuite/tests/ghci/prog-mhu002/c/C.hs - + testsuite/tests/ghci/prog-mhu002/d/Main.hs - + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stderr - + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stderr - + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.stdout - + testsuite/tests/ghci/prog-mhu002/unitA - + testsuite/tests/ghci/prog-mhu002/unitB - + testsuite/tests/ghci/prog-mhu002/unitC - + testsuite/tests/ghci/prog-mhu002/unitD - + testsuite/tests/ghci/prog-mhu003/Makefile - + testsuite/tests/ghci/prog-mhu003/a/A.hs - + testsuite/tests/ghci/prog-mhu003/all.T - + testsuite/tests/ghci/prog-mhu003/b/Foo.hs - + testsuite/tests/ghci/prog-mhu003/c/C.hs - + testsuite/tests/ghci/prog-mhu003/d/Foo.hs - + testsuite/tests/ghci/prog-mhu003/prog-mhu003.script - + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr - + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stdout - + testsuite/tests/ghci/prog-mhu003/unitA - + testsuite/tests/ghci/prog-mhu003/unitB - + testsuite/tests/ghci/prog-mhu003/unitC - + testsuite/tests/ghci/prog-mhu003/unitD - + testsuite/tests/ghci/prog-mhu004/Makefile - + testsuite/tests/ghci/prog-mhu004/a/Foo.hs - + testsuite/tests/ghci/prog-mhu004/all.T - + testsuite/tests/ghci/prog-mhu004/b/Foo.hs - + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.script - + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr - + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stdout - + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.script - + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.stdout - + testsuite/tests/ghci/prog-mhu004/unitA - + testsuite/tests/ghci/prog-mhu004/unitB - testsuite/tests/ghci/prog010/ghci.prog010.script - testsuite/tests/ghci/prog018/prog018.stdout - testsuite/tests/ghci/scripts/T13869.stdout - testsuite/tests/ghci/scripts/T13997.stdout - testsuite/tests/ghci/scripts/T17669.stdout - testsuite/tests/ghci/scripts/T18330.stdout - testsuite/tests/ghci/scripts/T1914.stdout - testsuite/tests/ghci/scripts/T20217.stdout - testsuite/tests/ghci/scripts/T20587.stdout - testsuite/tests/ghci/scripts/T21110.stderr - testsuite/tests/ghci/scripts/T6105.stdout - testsuite/tests/ghci/scripts/T8042.stdout - testsuite/tests/ghci/scripts/T8042recomp.stdout - testsuite/tests/ghci/scripts/ghci024.stdout - testsuite/tests/ghci/scripts/ghci024.stdout-mingw32 - testsuite/tests/ghci/scripts/ghci058.script - testsuite/tests/ghci/should_run/TopEnvIface.stdout - testsuite/tests/linters/notes.stdout - testsuite/tests/quasiquotation/T7918.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c8597196fb1da16ab26fb62cca8a8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c8597196fb1da16ab26fb62cca8a8… You're receiving this email because of your account on gitlab.haskell.org.

1 0