[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: compiler: Add export list to GHC.SysTools.Tasks
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Mar 3 16:27:53 UTC 2025
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
90f1190e by Ben Gamari at 2025-02-28T20:53:53-05:00
compiler: Add export list to GHC.SysTools.Tasks
- - - - -
ec826009 by Ben Gamari at 2025-02-28T20:53:53-05:00
compiler: Pass --target to llvm-as
As noted in #25793, this is necessary due to potential ambiguity on
Apple machines with Rosetta.
- - - - -
9c1647d1 by Andreas Klebinger at 2025-02-28T20:54:30-05:00
cmmMachOpFoldM: Add missing pattern matches for bitcasts.
Fixes #25771
- - - - -
6eb2f15b by John Ericson at 2025-03-03T11:27:29-05:00
Remove most of `GHC.Internal.Pack`
Since bd82ac9f4716e28b185758ae514691d5a50c003f when `GHC.Pack` was
deleted, it is no longer used except for one function by the RTS.
- - - - -
89f1a624 by Rodrigo Mesquita at 2025-03-03T11:27:30-05:00
ghci: Don't set virtualCWD on every iteration
The calls to withVirtualCWD were introduced to fix #2973, but this bug
is no longer reproducible, even when `withVirtualCWD` is dropped.
This cleanup was originally motivated by the performance of :steplocal,
but the performance problem has now been fixed at its root in the next
commit.
Even then, `withVirtualCWD` seems to now be an unnecessary artifact, and
removing it simplifies the interpreter with no apparent drawbacks (testsuite is
also happy with this change)
- - - - -
3ac82226 by Rodrigo Mesquita at 2025-03-03T11:27:30-05:00
ghci debugger: improve break/resume control flow
After interpreting bytecode (`evalStmt`), we may want to hand off
control to "GHCi.UI" in order to display an interactive break prompt:
1. When an /active/ breakpoint (one set with :break ...) is hit
2. At any breakpoint, when using :step from a breakpoint
3. At any breakpoint in the same function f, when :steplocal is called
from a breakpoint in f
4. At any breakpoint in the same module, when :stepmodule is used
Whether to pass control to the UI is now fully determined by
`handleRunStatus` which transforms an `EvalStatus_` into an
`ExecResult`. When `ExecBreak` is returned from `handleRunStatus` to
GHCi, it always means GHCi breaks.
`handleRunStatus` determines whether to loop and resume evaluation right away, or
when to return to GHCi (by returning `ExecBreak` or `ExecComplete`).
- (1) is queried using the `BreakpointStatus` message (the
`breakpointStatus` call)
- (2,3,4) are determined by the predicate `breakHere step span`, which
inspects the improved `SingleStep` type to determine whether we care
about this breakpoint even if it is not active.
This refactor solves two big performance problems with the previous control flow:
- We no longer call `withArgs/withProgram` repeatedly in the
break/resume loop, but rather just once "at the top".
- We now avoid computing the expensive `bindLocalsAtBreakpoint` for
breakpoints we'd never inspect.
In the interpreter_steplocal test added, calling `:steplocal` after breaking on `main = fib 25`
now takes 12 seconds rather than 49 seconds on my machine.
```
interpreter_steplocal(ghci) ghc/alloc 6,124,821,176 540,181,392 -91.2% GOOD
```
Fixes #25779
-------------------------
Metric Decrease:
interpreter_steplocal
-------------------------
- - - - -
14 changed files:
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Eval/Types.hs
- compiler/GHC/Settings/IO.hs
- compiler/GHC/SysTools/Tasks.hs
- distrib/configure.ac.in
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- hadrian/bindist/Makefile
- hadrian/cfg/system.config.in
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Generate.hs
- libraries/ghc-internal/src/GHC/Internal/Pack.hs
- m4/fp_settings.m4
Changes:
=====================================
compiler/GHC/Cmm/Opt.hs
=====================================
@@ -63,18 +63,23 @@ cmmMachOpFoldM _ (MO_VF_Broadcast lg _w) exprs =
[CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l)
_ -> Nothing
cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
- = Just $! case op of
- MO_S_Neg _ -> CmmLit (CmmInt (narrowS rep (-x)) rep)
- MO_Not _ -> CmmLit (CmmInt (complement x) rep)
+ = case op of
+ MO_S_Neg _ -> Just $! CmmLit (CmmInt (narrowS rep (-x)) rep)
+ MO_Not _ -> Just $! CmmLit (CmmInt (complement x) rep)
-- these are interesting: we must first narrow to the
-- "from" type, in order to truncate to the correct size.
-- The final narrow/widen to the destination type
-- is implicit in the CmmLit.
- MO_SF_Round _frm to -> CmmLit (CmmFloat (fromInteger x) to)
- MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
- MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
- MO_XX_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
+ MO_SF_Round _frm to -> Just $! CmmLit (CmmFloat (fromInteger x) to)
+ MO_SS_Conv from to -> Just $! CmmLit (CmmInt (narrowS from x) to)
+ MO_UU_Conv from to -> Just $! CmmLit (CmmInt (narrowU from x) to)
+ MO_XX_Conv from to -> Just $! CmmLit (CmmInt (narrowS from x) to)
+
+ -- Not as simply as it seems, since CmmFloat uses Rational, so skipping those
+ -- for now ...
+ MO_WF_Bitcast _w -> Nothing
+ MO_FW_Bitcast _w -> Nothing
_ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op
-- Eliminate shifts that are wider than the shiftee
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Runtime.Eval (
abandon, abandonAll,
getResumeContext,
getHistorySpan,
- getModBreaks,
+ getModBreaks, readModBreaks,
getHistoryModule,
setupBreakpoint,
back, forward,
@@ -130,14 +130,12 @@ import GHC.Tc.Zonk.Env ( ZonkFlexi (SkolemiseFlexi) )
import GHC.IfaceToCore
import Control.Monad
-import Control.Monad.Catch as MC
import Data.Array
import Data.Dynamic
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
import Data.List.NonEmpty (NonEmpty)
-import System.Directory
import Unsafe.Coerce ( unsafeCoerce )
import qualified GHC.Unit.Home.Graph as HUG
@@ -156,9 +154,8 @@ getHistoryModule = ibi_tick_mod . historyBreakpointId
getHistorySpan :: HscEnv -> History -> IO SrcSpan
getHistorySpan hsc_env hist = do
let ibi = historyBreakpointId hist
- HUG.lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env) >>= pure . \case
- Just hmi -> modBreaks_locs (getModBreaks hmi) ! ibi_tick_index ibi
- _ -> panic "getHistorySpan"
+ brks <- readModBreaks hsc_env (ibi_tick_mod ibi)
+ return $ modBreaks_locs brks ! ibi_tick_index ibi
{- | Finds the enclosing top level function name -}
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
@@ -166,9 +163,8 @@ getHistorySpan hsc_env hist = do
-- for each tick.
findEnclosingDecls :: HscEnv -> InternalBreakpointId -> IO [String]
findEnclosingDecls hsc_env ibi = do
- hmi <- expectJust <$> HUG.lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env)
- return $
- modBreaks_decls (getModBreaks hmi) ! ibi_tick_index ibi
+ brks <- readModBreaks hsc_env (ibi_tick_mod ibi)
+ return $ modBreaks_decls brks ! ibi_tick_index ibi
-- | Update fixity environment in the current interactive context.
updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
@@ -232,10 +228,9 @@ execStmt' stmt stmt_text ExecOptions{..} = do
updateFixityEnv fix_env
status <-
- withVirtualCWD $
- liftIO $ do
- let eval_opts = initEvalOpts idflags' (isStep execSingleStep)
- evalStmt interp eval_opts (execWrap hval)
+ liftIO $ do
+ let eval_opts = initEvalOpts idflags' (enableGhcStepMode execSingleStep)
+ evalStmt interp eval_opts (execWrap hval)
let ic = hsc_IC hsc_env
bindings = (ic_tythings ic, ic_gre_cache ic)
@@ -282,38 +277,17 @@ them. The relevant predicate is OccName.isDerivedOccName.
See #11051 for more background and examples.
-}
-withVirtualCWD :: GhcMonad m => m a -> m a
-withVirtualCWD m = do
- hsc_env <- getSession
-
- -- a virtual CWD is only necessary when we're running interpreted code in
- -- the same process as the compiler.
- case interpInstance <$> hsc_interp hsc_env of
- Just (ExternalInterp {}) -> m
- _ -> do
- let ic = hsc_IC hsc_env
- let set_cwd = do
- dir <- liftIO $ getCurrentDirectory
- case ic_cwd ic of
- Just dir -> liftIO $ setCurrentDirectory dir
- Nothing -> return ()
- return dir
-
- reset_cwd orig_dir = do
- virt_dir <- liftIO $ getCurrentDirectory
- hsc_env <- getSession
- let old_IC = hsc_IC hsc_env
- setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
- liftIO $ setCurrentDirectory orig_dir
-
- MC.bracket set_cwd reset_cwd $ \_ -> m
-
parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
emptyHistory :: Int -> BoundedList History
emptyHistory size = nilBL size
+-- | Turn an 'EvalStatus_' result from interpreting Haskell into a GHCi 'ExecResult'.
+--
+-- This function is responsible for resuming execution at an intermediate
+-- breakpoint if we don't care about that breakpoint (e.g. if using :steplocal
+-- or :stepmodule, rather than :step, we only care about certain breakpoints).
handleRunStatus :: GhcMonad m
=> SingleStep -> String
-> ResumeBindings
@@ -322,92 +296,107 @@ handleRunStatus :: GhcMonad m
-> BoundedList History
-> m ExecResult
-handleRunStatus step expr bindings final_ids status history0
- | RunAndLogSteps <- step = tracing
- | otherwise = not_tracing
- where
- tracing
- | EvalBreak apStack_ref (Just eval_break) resume_ctxt _ccs <- status
- = do
- hsc_env <- getSession
- let interp = hscInterp hsc_env
- let dflags = hsc_dflags hsc_env
- ibi <- liftIO $ evalBreakpointToId (hsc_HPT hsc_env) eval_break
- hmi <- liftIO $ expectJust <$>
- lookupHpt (hsc_HPT hsc_env) (moduleName (ibi_tick_mod ibi))
- let breaks = getModBreaks hmi
-
- b <- liftIO $
- breakpointStatus interp (modBreaks_flags breaks) (ibi_tick_index ibi)
- if b
- then not_tracing
- -- This breakpoint is explicitly enabled; we want to stop
- -- instead of just logging it.
- else do
- apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
- history1 <- liftIO $ mkHistory hsc_env apStack_fhv ibi
- let !history' = history1 `consBL` history0
- -- history is strict, otherwise our BoundedList is pointless.
- fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
- let eval_opts = initEvalOpts dflags True
- status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
- handleRunStatus RunAndLogSteps expr bindings final_ids
- status history'
- | otherwise
- = not_tracing
-
- not_tracing
- -- Hit a breakpoint
- | EvalBreak apStack_ref maybe_break resume_ctxt ccs <- status
- = do
- hsc_env <- getSession
- let interp = hscInterp hsc_env
- resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
- apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
- ibi <- case maybe_break of
- Nothing -> pure Nothing
- Just break -> fmap Just $ liftIO $
- evalBreakpointToId (hsc_HPT hsc_env) break
- (hsc_env1, names, span, decl) <- liftIO $
- bindLocalsAtBreakpoint hsc_env apStack_fhv ibi
- let
- resume = Resume
- { resumeStmt = expr
- , resumeContext = resume_ctxt_fhv
- , resumeBindings = bindings
- , resumeFinalIds = final_ids
- , resumeApStack = apStack_fhv
- , resumeBreakpointId = ibi
- , resumeSpan = span
- , resumeHistory = toListBL history0
- , resumeDecl = decl
- , resumeCCS = ccs
- , resumeHistoryIx = 0
- }
- hsc_env2 = pushResume hsc_env1 resume
-
- setSession hsc_env2
- return (ExecBreak names ibi)
+handleRunStatus step expr bindings final_ids status history0 = do
+ hsc_env <- getSession
+ let
+ interp = hscInterp hsc_env
+ dflags = hsc_dflags hsc_env
+ case status of
-- Completed successfully
- | EvalComplete allocs (EvalSuccess hvals) <- status
- = do hsc_env <- getSession
- let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
- final_names = map getName final_ids
- interp = hscInterp hsc_env
- liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)
- hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
- setSession hsc_env'
- return (ExecComplete (Right final_names) allocs)
+ EvalComplete allocs (EvalSuccess hvals) -> do
+ let
+ final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
+ final_names = map getName final_ids
+ liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)
+ hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
+ setSession hsc_env'
+ return (ExecComplete (Right final_names) allocs)
-- Completed with an exception
- | EvalComplete alloc (EvalException e) <- status
- = return (ExecComplete (Left (fromSerializableException e)) alloc)
-
+ EvalComplete alloc (EvalException e) ->
+ return (ExecComplete (Left (fromSerializableException e)) alloc)
+
+ -- Nothing case: we stopped when an exception was raised, not at a breakpoint.
+ EvalBreak apStack_ref Nothing resume_ctxt ccs -> do
+ resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
+ apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
+ let span = mkGeneralSrcSpan (fsLit "<unknown>")
+ (hsc_env1, names) <- liftIO $
+ bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing
+ let
+ resume = Resume
+ { resumeStmt = expr
+ , resumeContext = resume_ctxt_fhv
+ , resumeBindings = bindings
+ , resumeFinalIds = final_ids
+ , resumeApStack = apStack_fhv
+ , resumeBreakpointId = Nothing
+ , resumeSpan = span
+ , resumeHistory = toListBL history0
+ , resumeDecl = "<exception thrown>"
+ , resumeCCS = ccs
+ , resumeHistoryIx = 0
+ }
+ hsc_env2 = pushResume hsc_env1 resume
+
+ setSession hsc_env2
+ return (ExecBreak names Nothing)
+
+ -- Just case: we stopped at a breakpoint
+ EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
+ ibi <- liftIO $ evalBreakpointToId (hsc_HPT hsc_env) eval_break
+ tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi)
+ let
+ span = modBreaks_locs tick_brks ! ibi_tick_index ibi
+ decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi
+
+ 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.
+ 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
+ -- and simply resume execution from here until we hit a breakpoint we do want to stop at.
+ (hsc_env1, names) <- liftIO $
+ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi)
+ let
+ resume = Resume
+ { resumeStmt = expr
+ , resumeContext = resume_ctxt_fhv
+ , resumeBindings = bindings
+ , resumeFinalIds = final_ids
+ , resumeApStack = apStack_fhv
+ , resumeBreakpointId = Just ibi
+ , resumeSpan = span
+ , resumeHistory = toListBL history0
+ , resumeDecl = decl
+ , resumeCCS = ccs
+ , resumeHistoryIx = 0
+ }
+ hsc_env2 = pushResume hsc_env1 resume
+ setSession hsc_env2
+ return (ExecBreak names (Just ibi))
+ else do
+ let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
+ status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv
+ history <- if not tracing then pure history0 else do
+ history1 <- liftIO $ mkHistory hsc_env apStack_fhv ibi
+ let !history' = history1 `consBL` history0
+ -- history is strict, otherwise our BoundedList is pointless.
+ return history'
+ handleRunStatus step expr bindings final_ids status history
+ where
+ tracing | RunAndLogSteps <- step = True
+ | otherwise = False
-resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int
+resumeExec :: GhcMonad m => SingleStep -> Maybe Int
-> m ExecResult
-resumeExec canLogSpan step mbCnt
+resumeExec step mbCnt
= do
hsc_env <- getSession
let ic = hsc_IC hsc_env
@@ -445,42 +434,41 @@ resumeExec canLogSpan step mbCnt
, resumeBreakpointId = mb_brkpt
, resumeSpan = span
, resumeHistory = hist } ->
- withVirtualCWD $ do
+ do
-- When the user specified a break ignore count, set it
-- in the interpreter
case (mb_brkpt, mbCnt) of
(Just brkpt, Just cnt) -> setupBreakpoint hsc_env (toBreakpointId brkpt) cnt
_ -> return ()
- let eval_opts = initEvalOpts dflags (isStep step)
+ let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
let prevHistoryLst = fromListBL 50 hist
hist' = case mb_brkpt of
Nothing -> pure prevHistoryLst
Just bi
- | not $ canLogSpan span -> pure prevHistoryLst
- | otherwise -> do
+ | breakHere step span -> do
hist1 <- liftIO (mkHistory hsc_env apStack bi)
return $ hist1 `consBL` fromListBL 50 hist
+ | otherwise -> pure prevHistoryLst
handleRunStatus step expr bindings final_ids status =<< hist'
setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157
setupBreakpoint hsc_env bi cnt = do
let modl = bi_tick_mod bi
- modBreaks <- getModBreaks . expectJust <$>
- liftIO (lookupHpt (hsc_HPT hsc_env) (moduleName modl))
+ modBreaks <- liftIO $ readModBreaks hsc_env modl
let breakarray = modBreaks_flags modBreaks
interp = hscInterp hsc_env
_ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt
pure ()
-back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
+back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
back n = moveHist (+n)
-forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
+forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
forward n = moveHist (subtract n)
-moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
+moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
moveHist fn = do
hsc_env <- getSession
case ic_resume (hsc_IC hsc_env) of
@@ -498,15 +486,20 @@ moveHist fn = do
let
update_ic apStack mb_info = do
- (hsc_env1, names, span, decl) <-
- liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
+ span <- case mb_info of
+ Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>")
+ Just ibi -> liftIO $ do
+ brks <- readModBreaks hsc_env (ibi_tick_mod ibi)
+ return $ modBreaks_locs brks ! ibi_tick_index ibi
+ (hsc_env1, names) <-
+ liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info
let ic = hsc_IC hsc_env1
r' = r { resumeHistoryIx = new_ix }
ic' = ic { ic_resume = r':rs }
setSession hsc_env1{ hsc_IC = ic' }
- return (names, new_ix, span, decl)
+ return (names, new_ix, span)
-- careful: we want apStack to be the AP_STACK itself, not a thunk
-- around it, hence the cases are carefully constructed below to
@@ -527,19 +520,25 @@ moveHist fn = do
result_fs :: FastString
result_fs = fsLit "_result"
+-- | Read the 'ModBreaks' of the given home 'Module' from the 'HomeUnitGraph'.
+readModBreaks :: HscEnv -> Module -> IO ModBreaks
+readModBreaks hsc_env mod =
+ getModBreaks . expectJust <$>
+ HUG.lookupHugByModule mod (hsc_HUG hsc_env)
+
bindLocalsAtBreakpoint
:: HscEnv
-> ForeignHValue
+ -> SrcSpan
-> Maybe InternalBreakpointId
- -> IO (HscEnv, [Name], SrcSpan, String)
+ -> IO (HscEnv, [Name])
-- Nothing case: we stopped when an exception was raised, not at a
-- breakpoint. We have no location information or local variables to
-- bind, all we can do is bind a local variable to the exception
-- value.
-bindLocalsAtBreakpoint hsc_env apStack Nothing = do
+bindLocalsAtBreakpoint hsc_env apStack span Nothing = do
let exn_occ = mkVarOccFS (fsLit "_exception")
- span = mkGeneralSrcSpan (fsLit "<unknown>")
exn_name <- newInteractiveBinder hsc_env exn_occ span
let e_fs = fsLit "e"
@@ -552,32 +551,21 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
interp = hscInterp hsc_env
--
Loader.extendLoadedEnv interp [(exn_name, apStack)]
- return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
+ return (hsc_env{ hsc_IC = ictxt1 }, [exn_name])
-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
-bindLocalsAtBreakpoint hsc_env apStack_fhv (Just ibi) = do
- let
- interp = hscInterp hsc_env
-
- info_mod = ibi_info_mod ibi
- info_hmi <- expectJust <$> lookupHpt (hsc_HPT hsc_env) (moduleName info_mod)
- let
- info_brks = getModBreaks info_hmi
- info = expectJust $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks)
-
- tick_mod = ibi_tick_mod ibi
- tick_hmi <- expectJust <$> lookupHpt (hsc_HPT hsc_env) (moduleName tick_mod)
- let
- tick_brks = getModBreaks tick_hmi
- occs = modBreaks_vars tick_brks ! ibi_tick_index ibi
- span = modBreaks_locs tick_brks ! ibi_tick_index ibi
- decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi
+bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do
+ info_brks <- readModBreaks hsc_env (ibi_info_mod ibi)
+ tick_brks <- readModBreaks hsc_env (ibi_tick_mod ibi)
+ let info = expectJust $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks)
+ interp = hscInterp hsc_env
+ occs = modBreaks_vars tick_brks ! ibi_tick_index ibi
-- Rehydrate to understand the breakpoint info relative to the current environment.
-- This design is critical to preventing leaks (#22530)
(mbVars, result_ty) <- initIfaceLoad hsc_env
- $ initIfaceLcl info_mod (text "debugger") NotBoot
+ $ initIfaceLcl (ibi_info_mod ibi) (text "debugger") NotBoot
$ hydrateCgBreakInfo info
let
@@ -624,7 +612,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just ibi) = do
Loader.extendLoadedEnv interp (zip names fhvs)
when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)]
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
- return (hsc_env1, if result_ok then result_name:names else names, span, decl)
+ return (hsc_env1, if result_ok then result_name:names else names)
where
-- We need a fresh Unique for each Id we bind, because the linker
-- state is single-threaded and otherwise we'd spam old bindings
=====================================
compiler/GHC/Runtime/Eval/Types.hs
=====================================
@@ -9,7 +9,8 @@
module GHC.Runtime.Eval.Types (
Resume(..), ResumeBindings, IcGlobalRdrEnv(..),
History(..), ExecResult(..),
- SingleStep(..), isStep, ExecOptions(..)
+ SingleStep(..), enableGhcStepMode, breakHere,
+ ExecOptions(..)
) where
import GHC.Prelude
@@ -35,21 +36,59 @@ data ExecOptions
, execWrap :: ForeignHValue -> EvalExpr ForeignHValue
}
+-- | What kind of stepping are we doing?
data SingleStep
= RunToCompletion
- | SingleStep
+
+ -- | :trace [expr]
| RunAndLogSteps
-isStep :: SingleStep -> Bool
-isStep RunToCompletion = False
-isStep _ = True
+ -- | :step [expr]
+ | SingleStep
+
+ -- | :steplocal [expr]
+ | LocalStep
+ { breakAt :: SrcSpan }
+
+ -- | :stepmodule [expr]
+ | ModuleStep
+ { breakAt :: SrcSpan }
+
+-- | Whether this 'SingleStep' mode requires instructing the interpreter to
+-- step at every breakpoint.
+enableGhcStepMode :: SingleStep -> Bool
+enableGhcStepMode RunToCompletion = False
+enableGhcStepMode _ = True
+
+-- | 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.
+--
+-- In particular, this will always be @False@ for @'RunToCompletion'@ and
+-- @'RunAndLogSteps'@. We'd need further information e.g. about the user
+-- breakpoints to determine whether to break in those modes.
+breakHere :: SingleStep -> SrcSpan -> Bool
+breakHere step break_span = case step of
+ RunToCompletion -> False
+ RunAndLogSteps -> False
+ SingleStep -> True
+ LocalStep span -> break_span `isSubspanOf` span
+ ModuleStep span -> srcSpanFileName_maybe span == srcSpanFileName_maybe break_span
data ExecResult
+
+ -- | Execution is complete
= ExecComplete
{ execResult :: Either SomeException [Name]
, execAllocation :: Word64
}
- | ExecBreak
+
+ -- | Execution stopped at a breakpoint.
+ --
+ -- Note: `ExecBreak` is only returned by `handleRunStatus` when GHCi should
+ -- definitely stop at this breakpoint. GHCi is /not/ responsible for
+ -- subsequently deciding whether to really stop here.
+ -- `ExecBreak` always means GHCi breaks.
+ | ExecBreak
{ breakNames :: [Name]
, breakPointId :: Maybe InternalBreakpointId
}
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -168,6 +168,7 @@ initSettings top_dir = do
lc_prog <- getSetting "LLVM llc command"
lo_prog <- getSetting "LLVM opt command"
las_prog <- getSetting "LLVM llvm-as command"
+ las_args <- map Option . unescapeArgs <$> getSetting "LLVM llvm-as flags"
let iserv_prog = libexec "ghc-iserv"
@@ -225,7 +226,7 @@ initSettings top_dir = do
, toolSettings_pgm_ranlib = ranlib_path
, toolSettings_pgm_lo = (lo_prog,[])
, toolSettings_pgm_lc = (lc_prog,[])
- , toolSettings_pgm_las = (las_prog, [])
+ , toolSettings_pgm_las = (las_prog, las_args)
, toolSettings_pgm_i = iserv_prog
, toolSettings_opt_L = []
, toolSettings_opt_P = []
=====================================
compiler/GHC/SysTools/Tasks.hs
=====================================
@@ -7,7 +7,26 @@
-- (c) The GHC Team 2017
--
-----------------------------------------------------------------------------
-module GHC.SysTools.Tasks where
+module GHC.SysTools.Tasks
+ ( runUnlit
+ , SourceCodePreprocessor(..)
+ , runSourceCodePreprocessor
+ , runPp
+ , runCc
+ , askLd
+ , runAs
+ , runLlvmOpt
+ , runLlvmLlc
+ , runLlvmAs
+ , runEmscripten
+ , figureLlvmVersion
+ , runMergeObjects
+ , runAr
+ , askOtool
+ , runInstallNameTool
+ , runRanlib
+ , runWindres
+ ) where
import GHC.Prelude
import GHC.ForeignSrcLang
=====================================
distrib/configure.ac.in
=====================================
@@ -214,6 +214,13 @@ FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion])
LlvmAsCmd="$LLVMAS"
AC_SUBST([LlvmAsCmd])
+dnl We know that `clang` supports `--target` and it is necessary to pass it
+dnl lest we see #25793.
+if test -z "$LlvmAsFlags" ; then
+ LlvmAsFlags="--target=$LlvmTarget"
+fi
+AC_SUBST([LlvmAsFlags])
+
dnl ** Check gcc version and flags we need to pass it **
FP_GCC_VERSION
FP_GCC_SUPPORTS_NO_PIE
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -1310,7 +1310,7 @@ runStmt input step = do
m_result <- GhciMonad.runStmt stmt input step
case m_result of
Nothing -> return Nothing
- Just result -> Just <$> afterRunStmt (const True) result
+ Just result -> Just <$> afterRunStmt step result
-- `x = y` (a declaration) should be treated as `let x = y` (a statement).
-- The reason is because GHCi wasn't designed to support `x = y`, but then
@@ -1342,7 +1342,7 @@ runStmt input step = do
_ <- liftIO $ tryIO $ hFlushAll stdin
m_result <- GhciMonad.runDecls' decls
forM m_result $ \result ->
- afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)
+ afterRunStmt step (GHC.ExecComplete (Right result) 0)
mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
mk_stmt loc bind =
@@ -1359,9 +1359,9 @@ runStmt input step = do
modStr = moduleNameString $ moduleName $ icInteractiveModule $ ic
-- | Clean up the GHCi environment after a statement has run
-afterRunStmt :: GhciMonad m
- => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult
-afterRunStmt step_here run_result = do
+afterRunStmt :: GhciMonad m => SingleStep {-^ Type of step we took just before -}
+ -> GHC.ExecResult -> m GHC.ExecResult
+afterRunStmt step run_result = do
resumes <- GHC.getResumeContext
case run_result of
GHC.ExecComplete{..} ->
@@ -1372,9 +1372,7 @@ afterRunStmt step_here run_result = do
when show_types $ printTypeOfNames names
GHC.ExecBreak names mb_info
| first_resume : _ <- resumes
- , isNothing mb_info ||
- step_here (GHC.resumeSpan first_resume) -> do
- mb_id_loc <- toBreakIdAndLocation mb_info
+ -> do mb_id_loc <- toBreakIdAndLocation mb_info
let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
if (null bCmd)
then printStoppedAtBreakInfo first_resume names
@@ -1383,8 +1381,9 @@ afterRunStmt step_here run_result = do
st <- getGHCiState
enqueueCommands [stop st]
return ()
- | otherwise -> resume step_here GHC.SingleStep Nothing >>=
- afterRunStmt step_here >> return ()
+
+ | otherwise -> resume step Nothing >>=
+ afterRunStmt step >> return ()
flushInterpBuffers
withSignalHandlers $ do
@@ -3810,7 +3809,7 @@ forceCmd = pprintClosureCommand False True
stepCmd :: GhciMonad m => String -> m ()
stepCmd arg = withSandboxOnly ":step" $ step arg
where
- step [] = doContinue (const True) GHC.SingleStep
+ step [] = doContinue GHC.SingleStep
step expression = runStmt expression GHC.SingleStep >> return ()
stepLocalCmd :: GhciMonad m => String -> m ()
@@ -3829,7 +3828,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
Just loc -> do
md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule
current_toplevel_decl <- enclosingTickSpan md loc
- doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl Strict.Nothing) GHC.SingleStep
+ doContinue (GHC.LocalStep (RealSrcSpan current_toplevel_decl Strict.Nothing))
stepModuleCmd :: GhciMonad m => String -> m ()
stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
@@ -3840,9 +3839,7 @@ stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
mb_span <- getCurrentBreakSpan
case mb_span of
Nothing -> stepCmd []
- Just pan -> do
- let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
- doContinue f GHC.SingleStep
+ Just pan -> doContinue (GHC.ModuleStep pan)
-- | Returns the span of the largest tick containing the srcspan given
enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan
@@ -3863,14 +3860,14 @@ traceCmd :: GhciMonad m => String -> m ()
traceCmd arg
= withSandboxOnly ":trace" $ tr arg
where
- tr [] = doContinue (const True) GHC.RunAndLogSteps
+ tr [] = doContinue GHC.RunAndLogSteps
tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
continueCmd :: GhciMonad m => String -> m () -- #19157
continueCmd argLine = withSandboxOnly ":continue" $
case contSwitch (words argLine) of
Left sdoc -> printForUser sdoc
- Right mbCnt -> doContinue' (const True) GHC.RunToCompletion mbCnt
+ Right mbCnt -> doContinue' GHC.RunToCompletion mbCnt
where
contSwitch :: [String] -> Either SDoc (Maybe Int)
contSwitch [ ] = Right Nothing
@@ -3878,13 +3875,13 @@ continueCmd argLine = withSandboxOnly ":continue" $
contSwitch _ = Left $
text "After ':continue' only one ignore count is allowed"
-doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()
-doContinue pre step = doContinue' pre step Nothing
+doContinue :: GhciMonad m => SingleStep -> m ()
+doContinue step = doContinue' step Nothing
-doContinue' :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()
-doContinue' pre step mbCnt= do
- runResult <- resume pre step mbCnt
- _ <- afterRunStmt pre runResult
+doContinue' :: GhciMonad m => SingleStep -> Maybe Int -> m ()
+doContinue' step mbCnt= do
+ runResult <- resume step mbCnt
+ _ <- afterRunStmt step runResult
return ()
abandonCmd :: GhciMonad m => String -> m ()
@@ -4036,7 +4033,7 @@ backCmd arg
| otherwise = liftIO $ putStrLn "Syntax: :back [num]"
where
back num = withSandboxOnly ":back" $ do
- (names, _, pan, _) <- GHC.back num
+ (names, _, pan) <- GHC.back num
printForUser $ text "Logged breakpoint at" <+> ppr pan
printTypeOfNames names
-- run the command set with ":set stop <cmd>"
@@ -4050,7 +4047,7 @@ forwardCmd arg
| otherwise = liftIO $ putStrLn "Syntax: :forward [num]"
where
forward num = withSandboxOnly ":forward" $ do
- (names, ix, pan, _) <- GHC.forward num
+ (names, ix, pan) <- GHC.forward num
printForUser $ (if (ix == 0)
then text "Stopped at"
else text "Logged breakpoint at") <+> ppr pan
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -401,14 +401,14 @@ runDecls' decls = do
return Nothing)
(Just <$> GHC.runParsedDecls decls)
-resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> Maybe Int -> m GHC.ExecResult
-resume canLogSpan step mbIgnoreCnt = do
+resume :: GhciMonad m => GHC.SingleStep -> Maybe Int -> m GHC.ExecResult
+resume step mbIgnoreCnt = do
st <- getGHCiState
reifyGHCi $ \x ->
withProgName (progname st) $
withArgs (args st) $
reflectGHCi x $ do
- GHC.resumeExec canLogSpan step mbIgnoreCnt
+ GHC.resumeExec step mbIgnoreCnt
-- --------------------------------------------------------------------------
-- timing & statistics
=====================================
hadrian/bindist/Makefile
=====================================
@@ -131,6 +131,7 @@ lib/settings : config.mk
@echo ',("LLVM llc command", "$(SettingsLlcCommand)")' >> $@
@echo ',("LLVM opt command", "$(SettingsOptCommand)")' >> $@
@echo ',("LLVM llvm-as command", "$(SettingsLlvmAsCommand)")' >> $@
+ @echo ',("LLVM llvm-as flags", "$(SettingsLlvmAsFlags)")' >> $@
@echo ',("Use inplace MinGW toolchain", "$(SettingsUseDistroMINGW)")' >> $@
@echo
@echo ',("target RTS linker only supports shared libraries", "$(TargetRTSLinkerOnlySupportsSharedLibs)")' >> $@
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -85,6 +85,7 @@ settings-install_name_tool-command = @SettingsInstallNameToolCommand@
settings-llc-command = @SettingsLlcCommand@
settings-opt-command = @SettingsOptCommand@
settings-llvm-as-command = @SettingsLlvmAsCommand@
+settings-llvm-as-flags = @SettingsLlvmAsFlags@
settings-use-distro-mingw = @SettingsUseDistroMINGW@
target-has-libm = @TargetHasLibm@
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -91,6 +91,7 @@ data ToolchainSetting
| ToolchainSetting_LlcCommand
| ToolchainSetting_OptCommand
| ToolchainSetting_LlvmAsCommand
+ | ToolchainSetting_LlvmAsFlags
| ToolchainSetting_DistroMinGW
-- | Look up the value of a 'Setting' in @cfg/system.config@, tracking the
@@ -144,6 +145,7 @@ settingsFileSetting key = lookupSystemConfig $ case key of
ToolchainSetting_LlcCommand -> "settings-llc-command"
ToolchainSetting_OptCommand -> "settings-opt-command"
ToolchainSetting_LlvmAsCommand -> "settings-llvm-as-command"
+ ToolchainSetting_LlvmAsFlags -> "settings-llvm-as-flags"
ToolchainSetting_DistroMinGW -> "settings-use-distro-mingw" -- ROMES:TODO: This option doesn't seem to be in ghc-toolchain yet. It corresponds to EnableDistroToolchain
-- | An expression that looks up the value of a 'Setting' in @cfg/system.config@,
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -528,6 +528,7 @@ generateSettings settingsFile = do
, ("LLVM llc command", expr $ settingsFileSetting ToolchainSetting_LlcCommand)
, ("LLVM opt command", expr $ settingsFileSetting ToolchainSetting_OptCommand)
, ("LLVM llvm-as command", expr $ settingsFileSetting ToolchainSetting_LlvmAsCommand)
+ , ("LLVM llvm-as flags", expr $ settingsFileSetting ToolchainSetting_LlvmAsFlags)
, ("Use inplace MinGW toolchain", expr $ settingsFileSetting ToolchainSetting_DistroMinGW)
, ("target RTS linker only supports shared libraries", expr $ yesNo <$> targetRTSLinkerOnlySupportsSharedLibs)
=====================================
libraries/ghc-internal/src/GHC/Internal/Pack.hs
=====================================
@@ -12,95 +12,20 @@
-- Stability : internal
-- Portability : non-portable (GHC Extensions)
--
--- ⚠ Warning: Starting @base-4.18@, this module is being deprecated.
--- See https://gitlab.haskell.org/ghc/ghc/-/issues/21461 for more information.
---
---
---
--- This module provides a small set of low-level functions for packing
--- and unpacking a chunk of bytes. Used by code emitted by the compiler
--- plus the prelude libraries.
---
--- The programmer level view of packed strings is provided by a GHC
--- system library PackedString.
+-- This function is just used by `rts_mkString`
--
-----------------------------------------------------------------------------
module GHC.Internal.Pack
(
- -- (**) - emitted by compiler.
-
- packCString#,
unpackCString,
- unpackCString#,
- unpackNBytes#,
- unpackFoldrCString#, -- (**)
- unpackAppendCString#, -- (**)
)
where
import GHC.Internal.Base
-import GHC.Internal.List ( length )
-import GHC.Internal.ST
import GHC.Internal.Ptr
-data ByteArray ix = ByteArray ix ix ByteArray#
-data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
-
unpackCString :: Ptr a -> [Char]
unpackCString a@(Ptr addr)
| a == nullPtr = []
| otherwise = unpackCString# addr
-
-packCString# :: [Char] -> ByteArray#
-packCString# str = case (packString str) of { ByteArray _ _ bytes -> bytes }
-
-packString :: [Char] -> ByteArray Int
-packString str = runST (packStringST str)
-
-packStringST :: [Char] -> ST s (ByteArray Int)
-packStringST str =
- let len = length str in
- packNBytesST len str
-
-packNBytesST :: Int -> [Char] -> ST s (ByteArray Int)
-packNBytesST (I# length#) str =
- {-
- allocate an array that will hold the string
- (not forgetting the NUL byte at the end)
- -}
- new_ps_array (length# +# 1#) >>= \ ch_array ->
- -- fill in packed string from "str"
- fill_in ch_array 0# str >>
- -- freeze the puppy:
- freeze_ps_array ch_array length#
- where
- fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
- fill_in arr_in# idx [] =
- write_ps_array arr_in# idx (chr# 0#) >>
- return ()
-
- fill_in arr_in# idx (C# c : cs) =
- write_ps_array arr_in# idx c >>
- fill_in arr_in# (idx +# 1#) cs
-
--- (Very :-) ``Specialised'' versions of some CharArray things...
-
-new_ps_array :: Int# -> ST s (MutableByteArray s Int)
-write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
-freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
-
-new_ps_array size = ST $ \ s ->
- case (newByteArray# size s) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray bot bot barr# #) }
- where
- bot = errorWithoutStackTrace "new_ps_array"
-
-write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
- case writeCharArray# barr# n ch s# of { s2# ->
- (# s2#, () #) }
-
--- same as unsafeFreezeByteArray
-freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
- case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
- (# s2#, ByteArray 0 (I# len#) frozen# #) }
=====================================
m4/fp_settings.m4
=====================================
@@ -89,6 +89,7 @@ AC_DEFUN([FP_SETTINGS],
SettingsLlcCommand="$LlcCmd"
SettingsOptCommand="$OptCmd"
SettingsLlvmAsCommand="$LlvmAsCmd"
+ SettingsLlvmAsFlags="$LlvmAsCmd"
if test "$EnableDistroToolchain" = "YES"; then
# If the user specified --enable-distro-toolchain then we just use the
@@ -131,6 +132,7 @@ AC_DEFUN([FP_SETTINGS],
SUBST_TOOLDIR([SettingsLlcCommand])
SUBST_TOOLDIR([SettingsOptCommand])
SUBST_TOOLDIR([SettingsLlvmAsCommand])
+ SUBST_TOOLDIR([SettingsLlvmAsFlags])
fi
# Mac-only tools
@@ -171,5 +173,6 @@ AC_DEFUN([FP_SETTINGS],
AC_SUBST(SettingsLlcCommand)
AC_SUBST(SettingsOptCommand)
AC_SUBST(SettingsLlvmAsCommand)
+ AC_SUBST(SettingsLlvmAsFlags)
AC_SUBST(SettingsUseDistroMINGW)
])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8bb9dd201cdb21ce925577a4823ef40e0665af5a...3ac8222607ba91e0de2eb22577b3c491d20b818b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8bb9dd201cdb21ce925577a4823ef40e0665af5a...3ac8222607ba91e0de2eb22577b3c491d20b818b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250303/5825e483/attachment-0001.html>
More information about the ghc-commits
mailing list