[Git][ghc/ghc][wip/az/sync-ghc-exactprint] 5 commits: Remove most of `GHC.Internal.Pack`
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Mon Mar 3 22:34:57 UTC 2025
Alan Zimmerman pushed to branch wip/az/sync-ghc-exactprint at Glasgow Haskell Compiler / GHC
Commits:
3b78e139 by John Ericson at 2025-03-03T15:27:39-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.
- - - - -
b4fe0850 by Rodrigo Mesquita at 2025-03-03T15:28:16-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)
- - - - -
73ba1e6e by Rodrigo Mesquita at 2025-03-03T15:28:16-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
-------------------------
- - - - -
8d6bbd8d by Alan Zimmerman at 2025-03-03T22:34:41+00:00
[EPA] Sync with the ghc-exactprint repo
This brings it into line with the changes in
https://hackage.haskell.org/package/ghc-exactprint-1.12.0.0
But also keeps the latest changes from master.
- - - - -
b89deb21 by Alan Zimmerman at 2025-03-03T22:34:41+00:00
Apply 1 suggestion(s) to 1 file(s)
Co-authored-by: Brandon S. Allbery <allbery.b at gmail.com>
- - - - -
9 changed files:
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Eval/Types.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/Pack.hs
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
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
}
=====================================
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
=====================================
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# #) }
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -7,15 +8,14 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates #-}
@@ -38,6 +38,7 @@ import GHC.Base (NonEmpty(..))
import GHC.Core.Coercion.Axiom (Role(..))
import qualified GHC.Data.BooleanFormula as BF
import GHC.Data.FastString
+import qualified GHC.Data.Strict as Strict
import GHC.TypeLits
import GHC.Types.Basic hiding (EP)
import GHC.Types.Fixity
@@ -106,16 +107,19 @@ runEP epReader action = do
defaultEPState :: EPState
defaultEPState = EPState
- { epPos = (1,1)
- , dLHS = 0
- , pMarkLayout = False
- , pLHS = 0
- , dMarkLayout = False
- , dPriorEndPosition = (1,1)
- , uAnchorSpan = badRealSrcSpan
+ { uAnchorSpan = badRealSrcSpan
, uExtraDP = Nothing
, uExtraDPReturn = Nothing
, pAcceptSpan = False
+
+ , epPos = (1,1)
+ , pMarkLayout = False
+ , pLHS = LayoutStartCol 1
+
+ , dPriorEndPosition = (1,1)
+ , dMarkLayout = False
+ , dLHS = LayoutStartCol 1
+
, epComments = []
, epCommentsApplied = []
, epEof = Nothing
@@ -165,7 +169,7 @@ data EPState = EPState
-- Annotation
, uExtraDP :: !(Maybe EpaLocation) -- ^ Used to anchor a
-- list
- , uExtraDPReturn :: !(Maybe DeltaPos)
+ , uExtraDPReturn :: !(Maybe (SrcSpan, DeltaPos))
-- ^ Used to return Delta version of uExtraDP
, pAcceptSpan :: Bool -- ^ When we have processed an
-- entry of EpaDelta, accept the
@@ -452,7 +456,6 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
-- delta phase variables -----------------------------------
-- Calculate offset required to get to the start of the SrcSPan
!off <- getLayoutOffsetD
- let spanStart = ss2pos curAnchor
priorEndAfterComments <- getPriorEndD
let edp' = adjustDeltaForOffset
-- Use the propagated offset if one is set
@@ -471,7 +474,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
Just (EpaDelta _ dp _) -> (dp, Nothing)
-- Replace original with desired one. Allows all
-- list entry values to be DP (1,0)
- Just (EpaSpan (RealSrcSpan r _)) -> (dp, Just dp)
+ Just (EpaSpan ss@(RealSrcSpan r _)) -> (dp, Just (ss, dp))
where
dp = adjustDeltaForOffset
off (ss2delta priorEndAfterComments r)
@@ -480,6 +483,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
when (isJust medr) $ setExtraDPReturn medr
-- ---------------------------------------------
-- Preparation complete, perform the action
+ let spanStart = ss2pos curAnchor
when (priorEndAfterComments < spanStart) (do
debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart
modify (\s -> s { dPriorEndPosition = spanStart } ))
@@ -512,8 +516,8 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
Just (pos, prior) -> do
let dp = if pos == prior
then (DifferentLine 1 0)
- else origDelta pos prior
- debugM $ "EOF:(pos,posEnd,prior,dp) =" ++ showGhc (ss2pos pos, ss2posEnd pos, ss2pos prior, dp)
+ else adjustDeltaForOffset off (origDelta pos prior)
+ debugM $ "EOF:(pos,posend,prior,off,dp) =" ++ show (ss2pos pos, ss2posEnd pos, ss2pos prior, off, dp)
printStringAtLsDelta dp ""
setEofPos Nothing -- Only do this once
@@ -542,12 +546,13 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
return after
else return []
!trailing' <- markTrailing trailing_anns
- -- mapM_ printOneComment (concatMap tokComment $ following)
addCommentsA following
-- Update original anchor, comments based on the printing process
-- TODO:AZ: probably need to put something appropriate in instead of noSrcSpan
- let newAnchor = EpaDelta noSrcSpan edp []
+ let newAnchor = case anchor' of
+ EpaSpan s -> EpaDelta s edp []
+ _ -> EpaDelta noSrcSpan edp []
let r = case canUpdateAnchor of
CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs)
CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments
@@ -695,7 +700,7 @@ printStringAtRsC capture pa str = do
debugM $ "printStringAtRsC:p'=" ++ showAst p'
debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta noSrcSpan p' NoComments)
debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta noSrcSpan p' (map comment2LEpaComment cs'))
- return (EpaDelta noSrcSpan p' (map comment2LEpaComment cs'))
+ return (EpaDelta (RealSrcSpan pa Strict.Nothing) p' (map comment2LEpaComment cs'))
printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m ()
printStringAtRs' pa str = printStringAtRsC NoCaptureComments pa str >> return ()
@@ -1385,7 +1390,7 @@ printOneComment c@(Comment _str loc _r _mo) = do
dp' <- case mep of
Just (EpaDelta _ edp _) -> do
debugM $ "printOneComment:edp=" ++ show edp
- adjustDeltaForOffsetM edp
+ return edp
_ -> return dp
-- Start of debug printing
LayoutStartCol dOff <- getLayoutOffsetD
@@ -1398,28 +1403,10 @@ updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
updateAndApplyComment (Comment str anc pp mo) dp = do
applyComment (Comment str anc' pp mo)
where
- (r,c) = ss2posEnd pp
- dp'' = case anc of
- EpaDelta _ dp1 _ -> dp1
- EpaSpan (RealSrcSpan la _) ->
- if r == 0
- then (ss2delta (r,c+0) la)
- else (ss2delta (r,c) la)
- EpaSpan (UnhelpfulSpan _) -> SameLine 0
- dp' = case anc of
- EpaSpan (RealSrcSpan r1 _) ->
- if pp == r1
- then dp
- else dp''
- _ -> dp''
- op' = case dp' of
- SameLine n -> if n >= 0
- then EpaDelta noSrcSpan dp' NoComments
- else EpaDelta noSrcSpan dp NoComments
- _ -> EpaDelta noSrcSpan dp' NoComments
- anc' = if str == "" && op' == EpaDelta noSrcSpan (SameLine 0) NoComments -- EOF comment
- then EpaDelta noSrcSpan dp NoComments
- else EpaDelta noSrcSpan dp NoComments
+ ss = case anc of
+ EpaSpan ss' -> ss'
+ _ -> noSrcSpan
+ anc' = EpaDelta ss dp NoComments
-- ---------------------------------------------------------------------
@@ -1459,11 +1446,6 @@ commentAllocationIn ss = do
markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast
markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a
--- ---------------------------------------------------------------------
-
-markTopLevelList :: (Monad m, Monoid w) => ExactPrint ast => [ast] -> EP w m [ast]
-markTopLevelList ls = mapM (\a -> setLayoutTopLevelP $ markAnnotated a) ls
-
-- ---------------------------------------------------------------------
-- End of utility functions
-- ---------------------------------------------------------------------
@@ -1540,11 +1522,11 @@ instance ExactPrint (HsModule GhcPs) where
an0 <- markLensTok an lam_mod
m' <- markAnnotated m
- mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec
+ mdeprec' <- markAnnotated mdeprec
- mexports' <- setLayoutTopLevelP $ markAnnotated mexports
+ mexports' <- markAnnotated mexports
- an1 <- setLayoutTopLevelP $ markLensTok an0 lam_where
+ an1 <- markLensTok an0 lam_where
return (an1, Just m', mdeprec', mexports')
@@ -1595,8 +1577,8 @@ instance ExactPrint HsModuleImpDecls where
setAnnotationAnchor mid _anc _ cs = mid { id_cs = priorComments cs ++ getFollowingComments cs }
`debug` ("HsModuleImpDecls.setAnnotationAnchor:cs=" ++ showAst cs)
exact (HsModuleImpDecls cs imports decls) = do
- imports' <- markTopLevelList imports
- decls' <- markTopLevelList (filter notDocDecl decls)
+ imports' <- mapM markAnnotated imports
+ decls' <- mapM markAnnotated (filter notDocDecl decls)
return (HsModuleImpDecls cs imports' decls')
@@ -2535,8 +2517,7 @@ instance ExactPrint (HsLocalBinds GhcPs) where
setAnnotationAnchor a _ _ _ = a
exact (HsValBinds an valbinds) = do
- debugM $ "exact HsValBinds: an=" ++ showAst an
- an0 <- markLensFun' an lal_rest markEpToken
+ an0 <- markLensFun' an lal_rest markEpToken -- 'where'
case al_anchor $ anns an of
Just anc -> do
@@ -2548,9 +2529,9 @@ instance ExactPrint (HsLocalBinds GhcPs) where
medr <- getExtraDPReturn
an2 <- case medr of
Nothing -> return an1
- Just dp -> do
+ Just (ss,dp) -> do
setExtraDPReturn Nothing
- return $ an1 { anns = (anns an1) { al_anchor = Just (EpaDelta noSrcSpan dp []) }}
+ return $ an1 { anns = (anns an1) { al_anchor = Just (EpaDelta ss dp []) }}
return (HsValBinds an2 valbinds')
exact (HsIPBinds an bs) = do
@@ -4246,7 +4227,7 @@ printUnicode anc n = do
-- TODO: unicode support?
"forall" -> if spanLength (epaLocationRealSrcSpan anc) == 1 then "∀" else "forall"
s -> s
- loc <- printStringAtAAC NoCaptureComments (EpaDelta noSrcSpan (SameLine 0) []) str
+ loc <- printStringAtAAC NoCaptureComments (EpaDelta (getHasLoc anc) (SameLine 0) []) str
case loc of
EpaSpan _ -> return anc
EpaDelta ss dp [] -> return $ EpaDelta ss dp []
@@ -4901,18 +4882,6 @@ setLayoutBoth k = do
, pLHS = oldAnchorOffset} )
k <* reset
--- Use 'local', designed for this
-setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m a -> EP w m a
-setLayoutTopLevelP k = do
- debugM $ "setLayoutTopLevelP entered"
- oldAnchorOffset <- getLayoutOffsetP
- modify (\a -> a { pMarkLayout = False
- , pLHS = 0} )
- r <- k
- debugM $ "setLayoutTopLevelP:resetting"
- setLayoutOffsetP oldAnchorOffset
- return r
-
------------------------------------------------------------------------
getPosP :: (Monad m, Monoid w) => EP w m Pos
@@ -4931,10 +4900,10 @@ setExtraDP md = do
debugM $ "setExtraDP:" ++ show md
modify (\s -> s {uExtraDP = md})
-getExtraDPReturn :: (Monad m, Monoid w) => EP w m (Maybe DeltaPos)
+getExtraDPReturn :: (Monad m, Monoid w) => EP w m (Maybe (SrcSpan, DeltaPos))
getExtraDPReturn = gets uExtraDPReturn
-setExtraDPReturn :: (Monad m, Monoid w) => Maybe DeltaPos -> EP w m ()
+setExtraDPReturn :: (Monad m, Monoid w) => Maybe (SrcSpan, DeltaPos) -> EP w m ()
setExtraDPReturn md = do
debugM $ "setExtraDPReturn:" ++ show md
modify (\s -> s {uExtraDPReturn = md})
=====================================
utils/check-exact/Main.hs
=====================================
@@ -533,7 +533,7 @@ changeLocalDecls libdir (L l p) = do
os' = setEntryDP os (DifferentLine 2 0)
let sortKey = captureOrderBinds decls
let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van
- let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 5) [])) a b c dd) cs)
+ let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b c dd) cs)
let binds' = (HsValBinds van'
(ValBinds sortKey (decl':oldBinds)
(sig':os':oldSigs)))
@@ -557,8 +557,8 @@ changeLocalDecls2 libdir (L l p) = do
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do
- let anc = (EpaDelta noSrcSpan (DifferentLine 1 3) [])
- let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 5) [])
+ let anc = (EpaDelta noSrcSpan (DifferentLine 1 2) [])
+ let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 4) [])
let an = EpAnn anc
(AnnList (Just anc2) ListNone
[]
@@ -937,13 +937,13 @@ addClassMethod :: Changer
addClassMethod libdir lp = do
Right sig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
Right decl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
- let decl' = setEntryDP decl (DifferentLine 1 3)
- let sig' = setEntryDP sig (DifferentLine 2 3)
+ let decl' = setEntryDP decl (DifferentLine 1 2)
+ let sig' = setEntryDP sig (DifferentLine 2 2)
let doAddMethod = do
let
[cd] = hsDecls lp
(f1:f2s:f2d:_) = hsDecls cd
- f2s' = setEntryDP f2s (DifferentLine 2 3)
+ f2s' = setEntryDP f2s (DifferentLine 2 2)
cd' = replaceDecls cd [f1, sig', decl', f2s', f2d]
lp' = replaceDecls lp [cd']
return lp'
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -258,12 +258,15 @@ setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp
setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp
= L (EpAnn (EpaDelta ss d' csd') an cs') a
where
+ -- I suspect we should assume the comments are already in the
+ -- right place, and just set the entry DP for this case. This
+ -- avoids surprises from the caller.
(d', csd', cs') = case cs of
EpaComments (h:t) ->
let
(dp0,c') = go h
in
- (dp0, c':t++csd, EpaComments [])
+ (dp0, csd, EpaComments (c':t))
EpaComments [] ->
(dp, csd, cs)
EpaCommentsBalanced (h:t) ts ->
@@ -299,7 +302,9 @@ setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp
line = getDeltaLine delta
col = deltaColumn delta
edp' = if line == 0 then SameLine col
- else DifferentLine line col
+ else DifferentLine line (col - 1)
+ -- At the top level the layout offset is 1, adjust for it
+ -- TODO: what about the layout offset for nested items?
edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ epaLocationRealSrcSpan $ getLoc lc), r))
@@ -330,17 +335,23 @@ setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP
-- ---------------------------------------------------------------------
--- |Take the annEntryDelta associated with the first item and associate it with the second.
--- Also transfer any comments occurring before it.
+-- |Take the annEntryDelta associated with the first item and
+-- associate it with the second. Also transfer any comments occurring
+-- before it.
transferEntryDP :: (Typeable t1, Typeable t2)
=> LocatedAn t1 a -> LocatedAn t2 b -> (LocatedAn t2 b)
-transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn _anc2 an2 cs2) b) =
+transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn anc2 an2 cs2) b) =
+ -- Note: the EpaDelta version of an EpaLocation contains the original
+ -- SrcSpan. We must preserve that.
+ let anc1' = case (anc1,anc2) of
+ (EpaDelta _ dp cs, EpaDelta ss2 _ _) -> EpaDelta ss2 dp cs
+ (_, _) -> anc1
-- Problem: if the original had preceding comments, blindly
-- transferring the location is not correct
- case priorComments cs1 of
- [] -> (L (EpAnn anc1 (combine an1 an2) cs2) b)
+ in case priorComments cs1 of
+ [] -> (L (EpAnn anc1' (combine an1 an2) cs2) b)
-- TODO: what happens if the receiving side already has comments?
- (L _ _:_) -> (L (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) b)
+ (L _ _:_) -> (L (EpAnn anc1' (combine an1 an2) (cs1 <> cs2)) b)
-- |If a and b are the same type return first arg, else return second
@@ -519,7 +530,7 @@ balanceCommentsA la1 la2 = (la1', la2')
anc2 = comments an2
(p1,m1,f1) = splitComments (anchorFromLocatedA la1) anc1
- cs1p = priorCommentsDeltas (anchorFromLocatedA la1) p1
+ cs1p = priorCommentsDeltas (anchorFromLocatedA la1) p1
-- Split cs1 following comments into those before any
-- TrailingAnn's on an1, and any after
@@ -1103,8 +1114,8 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = an'
newWhereAnnotation :: WithWhere -> (EpAnn (AnnList (EpToken "where")))
newWhereAnnotation ww = an
where
- anc = EpaDelta noSrcSpan (DifferentLine 1 3) []
- anc2 = EpaDelta noSrcSpan (DifferentLine 1 5) []
+ anc = EpaDelta noSrcSpan (DifferentLine 1 2) []
+ anc2 = EpaDelta noSrcSpan (DifferentLine 1 4) []
w = case ww of
WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) [])
WithoutWhere -> NoEpTok
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -141,7 +141,7 @@ undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc)
-- ---------------------------------------------------------------------
adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
-adjustDeltaForOffset _colOffset dp@(SameLine _) = dp
+adjustDeltaForOffset _colOffset dp@(SameLine _) = dp
adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c)
= DifferentLine l (c - colOffset)
@@ -196,14 +196,17 @@ isPointSrcSpan ss = spanLength ss == 0
-- does not already have one.
commentOrigDelta :: LEpaComment -> LEpaComment
commentOrigDelta (L (EpaSpan ss@(RealSrcSpan la _)) (GHC.EpaComment t pp))
- = (L (EpaDelta ss dp NoComments) (GHC.EpaComment t pp))
- `debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp))
+ = (L (EpaDelta ss dp' NoComments) (GHC.EpaComment t pp))
+ `debug` ("commentOrigDelta: (la, pp, r,c, dp, dp')=" ++ showAst (la, pp, r,c, dp, dp'))
where
(r,c) = ss2posEnd pp
dp = if r == 0
then (ss2delta (r,c+1) la)
else (ss2delta (r,c) la)
+ dp' = case dp of
+ SameLine _ -> dp
+ DifferentLine l cc -> DifferentLine l (cc - 1)
commentOrigDelta c = c
origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/531b275c8b980b03fe7f2085aa3eae694a840741...b89deb214cce933df9ed91d12938f29270798bbf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/531b275c8b980b03fe7f2085aa3eae694a840741...b89deb214cce933df9ed91d12938f29270798bbf
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/4dcc2e47/attachment-0001.html>
More information about the ghc-commits
mailing list