[Git][ghc/ghc][wip/splice-imports-2025] 5 commits: Documentation
by Matthew Pickering (＠mpickering) 17 Apr '25
by Matthew Pickering (＠mpickering) 17 Apr '25
17 Apr '25
Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC
Commits:
9c357ba0 by Matthew Pickering at 2025-04-17T11:14:14+01:00
Documentation
- - - - -
ddbba2de by Matthew Pickering at 2025-04-17T11:55:35+01:00
wip, fix level numbers
- - - - -
cf9d37cd by Matthew Pickering at 2025-04-17T14:01:44+01:00
fixes
- - - - -
680d0f57 by Matthew Pickering at 2025-04-17T14:36:39+01:00
Levels rather than stages
- - - - -
49dd7238 by Matthew Pickering at 2025-04-17T14:42:24+01:00
Delete dead code (I tested the tests worked)
- - - - -
81 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/TH.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- − compiler/Language/Haskell/Syntax/ImpExp/ImportLevel.hs
- compiler/ghc.cabal.in
- docs/users_guide/exts/template_haskell.rst
- docs/users_guide/phases.rst
- docs/users_guide/using-warnings.rst
- testsuite/tests/annotations/should_fail/annfail03.stderr
- testsuite/tests/annotations/should_fail/annfail04.stderr
- testsuite/tests/annotations/should_fail/annfail06.stderr
- testsuite/tests/annotations/should_fail/annfail09.stderr
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/quasiquotation/qq001/qq001.stderr
- testsuite/tests/quasiquotation/qq002/qq002.stderr
- testsuite/tests/quasiquotation/qq003/qq003.stderr
- testsuite/tests/quasiquotation/qq004/qq004.stderr
- testsuite/tests/quotes/T5721.stderr
- testsuite/tests/splice-imports/SI03.stderr
- testsuite/tests/splice-imports/SI05.stderr
- testsuite/tests/splice-imports/SI08.stderr
- testsuite/tests/splice-imports/SI08_oneshot.stderr
- testsuite/tests/splice-imports/SI14.stderr
- testsuite/tests/splice-imports/SI15.stderr
- testsuite/tests/splice-imports/SI16.stderr
- testsuite/tests/splice-imports/SI18.stderr
- testsuite/tests/splice-imports/SI20.stderr
- + testsuite/tests/splice-imports/SI25.hs
- + testsuite/tests/splice-imports/SI25.stderr
- + testsuite/tests/splice-imports/SI25Helper.hs
- + testsuite/tests/splice-imports/SI26.hs
- + testsuite/tests/splice-imports/SI27.hs
- + testsuite/tests/splice-imports/SI27.stderr
- testsuite/tests/splice-imports/all.T
- testsuite/tests/th/T16976z.stderr
- testsuite/tests/th/T17820a.stderr
- testsuite/tests/th/T17820b.stderr
- testsuite/tests/th/T17820c.stderr
- testsuite/tests/th/T17820d.stderr
- testsuite/tests/th/T17820e.stderr
- testsuite/tests/th/T21547.stderr
- testsuite/tests/th/T23829_hasty.stderr
- testsuite/tests/th/T23829_hasty_b.stderr
- testsuite/tests/th/T23829_tardy.ghc.stderr
- testsuite/tests/th/T5795.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e1422c8a8e163070028b4b064544e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e1422c8a8e163070028b4b064544e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-debugger-unitid] Add `UnitId` to `EvalBreakpoint`
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-debugger-unitid at Glasgow Haskell Compiler / GHC
Commits:
91cb9703 by fendor at 2025-04-17T14:38:42+02:00
Add `UnitId` to `EvalBreakpoint`
The `EvalBreakpoint` is used to communicate that a breakpoint was
encountered during code evaluation.
This `EvalBreakpoint` needs to be converted to an `InternalBreakpointId`
which stores a `Module` to uniquely find the correct `Module` in the
Home Package Table.
The `EvalBreakpoint` used to store only a `ModuleName` which is then
converted to a `Module` based on the currently active home unit.
This is incorrect in the face of multiple home units, the break point
could be in an entirely other home unit!
To fix this, we additionally store the `UnitId` of the `Module` in
`EvalBreakpoint` to later reconstruct the correct `Module`
All of the changes are the consequence of extending `EvalBreakpoint`
with the additional `UnitId`.
- - - - -
11 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Exception.cmm
- rts/Interpreter.c
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -732,13 +732,16 @@ assembleI platform i = case i of
CCALL off m_addr i -> do np <- addr m_addr
emit_ bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit_ bci_PRIMCALL []
- BRK_FUN arr tick_mod tickx info_mod infox cc ->
+ BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc ->
do p1 <- ptr (BCOPtrBreakArray arr)
tick_addr <- addr tick_mod
+ tick_unitid_addr <- addr tick_mod_id
info_addr <- addr info_mod
+ info_unitid_addr <- addr info_mod_id
np <- addr cc
emit_ bci_BRK_FUN [ Op p1
, Op tick_addr, Op info_addr
+ , Op tick_unitid_addr, Op info_unitid_addr
, SmallOp tickx, SmallOp infox
, Op np
]
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
import Language.Haskell.Syntax.Module.Name (ModuleName)
import GHC.Types.Unique
+import GHC.Unit.Types (UnitId)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -233,8 +234,10 @@ data BCInstr
-- Breakpoints
| BRK_FUN (ForeignRef BreakArray)
(RemotePtr ModuleName) -- breakpoint tick module
+ (RemotePtr UnitId) -- breakpoint tick module unit id
!Word16 -- breakpoint tick index
(RemotePtr ModuleName) -- breakpoint info module
+ (RemotePtr UnitId) -- breakpoint info module unit id
!Word16 -- breakpoint info index
(RemotePtr CostCentre)
@@ -403,10 +406,10 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)
+ ppr (BRK_FUN _ _tick_mod _tick_mod_id tickx _info_mod _info_mod_id infox _)
= text "BRK_FUN" <+> text "<breakarray>"
- <+> text "<tick_module>" <+> ppr tickx
- <+> text "<info_module>" <+> ppr infox
+ <+> text "<tick_module>" <+> text "<tick_module_unitid>" <+> ppr tickx
+ <+> text "<info_module>" <+> text "<info_module_unitid>" <+> ppr infox
<+> text "<cc>"
#if MIN_VERSION_rts(1,0,3)
ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm)
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -50,6 +50,7 @@ import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
import GHC.Iface.Syntax
import Language.Haskell.Syntax.Module.Name (ModuleName)
+import GHC.Unit.Types (UnitId)
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -263,6 +264,9 @@ data ModBreaks
, modBreaks_breakInfo :: IntMap CgBreakInfo
-- ^ info about each breakpoint from the bytecode generator
, modBreaks_module :: RemotePtr ModuleName
+ -- ^ info about the module in which we are setting the breakpoint
+ , modBreaks_module_unitid :: RemotePtr UnitId
+ -- ^ The 'UnitId' of the 'ModuleName'
}
seqModBreaks :: ModBreaks -> ()
@@ -273,7 +277,8 @@ seqModBreaks ModBreaks{..} =
rnf modBreaks_decls `seq`
rnf modBreaks_ccs `seq`
rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`
- rnf modBreaks_module
+ rnf modBreaks_module `seq`
+ rnf modBreaks_module_unitid
-- | Construct an empty ModBreaks
emptyModBreaks :: ModBreaks
@@ -286,6 +291,7 @@ emptyModBreaks = ModBreaks
, modBreaks_ccs = array (0,-1) []
, modBreaks_breakInfo = IntMap.empty
, modBreaks_module = toRemotePtr nullPtr
+ , modBreaks_module_unitid = toRemotePtr nullPtr
}
{-
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -34,7 +34,7 @@ mkModBreaks interp mod extendedMixEntries
breakArray <- GHCi.newBreakArray interp count
ccs <- mkCCSArray interp mod count entries
- mod_ptr <- GHCi.newModuleName interp (moduleName mod)
+ (mod_ptr, mod_id_ptr) <- GHCi.newModule interp mod
let
locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
@@ -46,6 +46,7 @@ mkModBreaks interp mod extendedMixEntries
, modBreaks_decls = declsTicks
, modBreaks_ccs = ccs
, modBreaks_module = mod_ptr
+ , modBreaks_module_unitid = mod_id_ptr
}
mkCCSArray
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
-- 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
+ let ibi = evalBreakpointToId eval_break
tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi)
let
span = modBreaks_locs tick_brks ! ibi_tick_index ibi
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Runtime.Interpreter
, mkCostCentres
, costCentreStackInfo
, newBreakArray
- , newModuleName
+ , newModule
, storeBreakpoint
, breakpointStatus
, getBreakpointVar
@@ -93,9 +93,7 @@ import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)
import GHC.Utils.Fingerprint
import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo
-import GHC.Unit.Home.PackageTable
import GHC.Unit.Env
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -119,6 +117,7 @@ import qualified GHC.InfoProv as InfoProv
import GHC.Builtin.Names
import GHC.Types.Name
+import qualified GHC.Unit.Home.Graph as HUG
-- Standard libraries
import GHC.Exts
@@ -377,9 +376,13 @@ newBreakArray interp size = do
breakArray <- interpCmd interp (NewBreakArray size)
mkFinalizedHValue interp breakArray
-newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
-newModuleName interp mod_name =
- castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name))
+newModule :: Interp -> Module -> IO (RemotePtr ModuleName, RemotePtr UnitId)
+newModule interp mod = do
+ let
+ mod_name = moduleNameString $ moduleName mod
+ mod_id = unitIdString $ toUnitId $ moduleUnit mod
+ (mod_ptr, mod_id_ptr) <- interpCmd interp (NewBreakModule mod_name mod_id)
+ pure (castRemotePtr mod_ptr, castRemotePtr mod_id_ptr)
storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
storeBreakpoint interp ref ix cnt = do -- #19157
@@ -415,19 +418,21 @@ seqHValue interp unit_env ref =
status <- interpCmd interp (Seq hval)
handleSeqHValueStatus interp unit_env status
-evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> IO InternalBreakpointId
-evalBreakpointToId hpt eval_break =
- let load_mod x = mi_module . hm_iface . expectJust <$> lookupHpt hpt (mkModuleName x)
- in do
- tickl <- load_mod (eb_tick_mod eval_break)
- infol <- load_mod (eb_info_mod eval_break)
- return
- InternalBreakpointId
- { ibi_tick_mod = tickl
- , ibi_tick_index = eb_tick_index eval_break
- , ibi_info_mod = infol
- , ibi_info_index = eb_info_index eval_break
- }
+evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
+evalBreakpointToId eval_break =
+ let
+ mkUnitId u = RealUnit (Definite $ stringToUnitId u)
+
+ toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break)
+ infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
+ in
+ InternalBreakpointId
+ { ibi_tick_mod = tickl
+ , ibi_tick_index = eb_tick_index eval_break
+ , ibi_info_mod = infol
+ , ibi_info_index = eb_info_index eval_break
+ }
-- | Process the result of a Seq or ResumeSeq message. #2950
handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
@@ -447,12 +452,12 @@ handleSeqHValueStatus interp unit_env eval_status =
mkGeneralSrcSpan (fsLit "<unknown>")
Just break -> do
- bi <- evalBreakpointToId (ue_hpt unit_env) break
+ let bi = evalBreakpointToId break
-- Just case: Stopped at a breakpoint, extract SrcSpan information
-- from the breakpoint.
breaks_tick <- getModBreaks . expectJust <$>
- lookupHpt (ue_hpt unit_env) (moduleName (ibi_tick_mod bi))
+ HUG.lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
put $ brackets . ppr $
(modBreaks_locs breaks_tick) ! ibi_tick_index bi
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -416,7 +416,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
Nothing -> pure code
Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case
Nothing -> pure code
- Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do
+ Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_module_unitid = tick_mod_id_ptr, modBreaks_ccs = cc_arr} -> do
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
@@ -425,6 +425,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
let info_mod_ptr = modBreaks_module current_mod_breaks
+ info_mod_id_ptr = modBreaks_module_unitid current_mod_breaks
infox <- newBreakInfo breakInfo
let cc | Just interp <- hsc_interp hsc_env
@@ -437,7 +438,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
in if fromIntegral r == x
then r
else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
- breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc
+ breakInstr = BRK_FUN breaks tick_mod_ptr tick_mod_id_ptr (toW16 tick_no) info_mod_ptr info_mod_id_ptr (toW16 infox) cc
return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -23,6 +23,7 @@ module GHCi.Message
, getMessage, putMessage, getTHMessage, putTHMessage
, Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe
, BreakModule
+ , BreakUnitId
, LoadedDLL
) where
@@ -245,8 +246,9 @@ data Message a where
-- | Allocate a string for a breakpoint module name.
-- This uses an empty dummy type because @ModuleName@ isn't available here.
NewBreakModule
- :: String
- -> Message (RemotePtr BreakModule)
+ :: String -- ^ @ModuleName@
+ -> String -- ^ @UnitId@ for the given @ModuleName@
+ -> Message (RemotePtr BreakModule, RemotePtr BreakUnitId)
deriving instance Show (Message a)
@@ -410,10 +412,12 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_tick_mod :: String -- ^ Breakpoint tick module
- , eb_tick_index :: Int -- ^ Breakpoint tick index
- , eb_info_mod :: String -- ^ Breakpoint info module
- , eb_info_index :: Int -- ^ Breakpoint info index
+ { eb_tick_mod :: String -- ^ Breakpoint tick module
+ , eb_tick_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_tick_index :: Int -- ^ Breakpoint tick index
+ , eb_info_mod :: String -- ^ Breakpoint info module
+ , eb_info_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_info_index :: Int -- ^ Breakpoint info index
}
deriving (Generic, Show)
@@ -430,6 +434,10 @@ instance Binary a => Binary (EvalResult a)
-- that type isn't available here.
data BreakModule
+-- | A dummy type that tags the pointer to a breakpoint's @UnitId@, because
+-- that type isn't available here.
+data BreakUnitId
+
-- | A dummy type that tags pointers returned by 'LoadDLL'.
data LoadedDLL
@@ -580,7 +588,7 @@ getMessage = do
36 -> Msg <$> (Seq <$> get)
37 -> Msg <$> return RtsRevertCAFs
38 -> Msg <$> (ResumeSeq <$> get)
- 39 -> Msg <$> (NewBreakModule <$> get)
+ 39 -> Msg <$> (NewBreakModule <$> get <*> get)
40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
41 -> Msg <$> (WhereFrom <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
@@ -627,7 +635,7 @@ putMessage m = case m of
Seq a -> putWord8 36 >> put a
RtsRevertCAFs -> putWord8 37
ResumeSeq a -> putWord8 38 >> put a
- NewBreakModule name -> putWord8 39 >> put name
+ NewBreakModule name unitid -> putWord8 39 >> put name >> put unitid
LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str
WhereFrom a -> putWord8 41 >> put a
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -95,7 +95,10 @@ run m = case m of
MkCostCentres mod ccs -> mkCostCentres mod ccs
CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
- NewBreakModule name -> newModuleName name
+ NewBreakModule name unitid -> do
+ namePtr <- newModuleName name
+ uidPtr <- newUnitId unitid
+ pure (namePtr, uidPtr)
SetupBreakpoint ref ix cnt -> do
arr <- localRef ref;
_ <- setupBreakpoint arr ix cnt
@@ -335,7 +338,7 @@ withBreakAction opts breakMVar statusMVar act
-- as soon as it is hit, or in resetBreakAction below.
onBreak :: BreakpointCallback
- onBreak tick_mod# tickx# info_mod# infox# is_exception apStack = do
+ onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do
tid <- myThreadId
let resume = ResumeContext
{ resumeBreakMVar = breakMVar
@@ -349,8 +352,10 @@ withBreakAction opts breakMVar statusMVar act
then pure Nothing
else do
tick_mod <- peekCString (Ptr tick_mod#)
+ tick_mod_uid <- peekCString (Ptr tick_mod_uid#)
info_mod <- peekCString (Ptr info_mod#)
- pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#)))
+ info_mod_uid <- peekCString (Ptr info_mod_uid#)
+ pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
takeMVar breakMVar
@@ -400,8 +405,10 @@ resetStepFlag = poke stepFlag 0
type BreakpointCallback
= Addr# -- pointer to the breakpoint tick module name
+ -> Addr# -- pointer to the breakpoint tick module unit id
-> Int# -- breakpoint tick index
-> Addr# -- pointer to the breakpoint info module name
+ -> Addr# -- pointer to the breakpoint info module unit id
-> Int# -- breakpoint info index
-> Bool -- exception?
-> HValue -- the AP_STACK, or exception
@@ -414,8 +421,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: BreakpointCallback
-noBreakAction _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction _ _ _ _ True _ = return () -- exception: just continue
+noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue
-- Malloc and copy the bytes. We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
@@ -453,6 +460,10 @@ newModuleName :: String -> IO (RemotePtr BreakModule)
newModuleName name =
castRemotePtr . toRemotePtr <$> newCString name
+newUnitId :: String -> IO (RemotePtr BreakUnitId)
+newUnitId name =
+ castRemotePtr . toRemotePtr <$> newCString name
+
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
case getApStackVal# apStack stackDepth of
=====================================
rts/Exception.cmm
=====================================
@@ -535,12 +535,16 @@ retry_pop_stack:
// be per-thread.
CInt[rts_stop_on_exception] = 0;
("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
- Sp = Sp - WDS(13);
- Sp(12) = exception;
- Sp(11) = stg_raise_ret_info;
- Sp(10) = exception;
- Sp(9) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
- Sp(8) = stg_ap_ppv_info;
+ Sp = Sp - WDS(17);
+ Sp(16) = exception;
+ Sp(15) = stg_raise_ret_info;
+ Sp(14) = exception;
+ Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
+ Sp(12) = stg_ap_ppv_info;
+ Sp(11) = 0;
+ Sp(10) = stg_ap_n_info;
+ Sp(9) = 0;
+ Sp(8) = stg_ap_n_info;
Sp(7) = 0;
Sp(6) = stg_ap_n_info;
Sp(5) = 0;
=====================================
rts/Interpreter.c
=====================================
@@ -1245,9 +1245,9 @@ run_BCO:
/* check for a breakpoint on the beginning of a let binding */
case bci_BRK_FUN:
{
- int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_index, arg5_info_index;
+ int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index;
#if defined(PROFILING)
- int arg6_cc;
+ int arg8_cc;
#endif
StgArrBytes *breakPoints;
int returning_from_break;
@@ -1264,10 +1264,12 @@ run_BCO:
arg1_brk_array = BCO_GET_LARGE_ARG;
arg2_tick_mod = BCO_GET_LARGE_ARG;
arg3_info_mod = BCO_GET_LARGE_ARG;
- arg4_tick_index = BCO_NEXT;
- arg5_info_index = BCO_NEXT;
+ arg4_tick_mod_id = BCO_GET_LARGE_ARG;
+ arg5_info_mod_id = BCO_GET_LARGE_ARG;
+ arg6_tick_index = BCO_NEXT;
+ arg7_info_index = BCO_NEXT;
#if defined(PROFILING)
- arg6_cc = BCO_GET_LARGE_ARG;
+ arg8_cc = BCO_GET_LARGE_ARG;
#else
BCO_GET_LARGE_ARG;
#endif
@@ -1280,7 +1282,7 @@ run_BCO:
#if defined(PROFILING)
cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
- (CostCentre*)BCO_LIT(arg6_cc));
+ (CostCentre*)BCO_LIT(arg8_cc));
#endif
// if we are returning from a break then skip this section
@@ -1292,11 +1294,11 @@ run_BCO:
// stop the current thread if either the
// "rts_stop_next_breakpoint" flag is true OR if the
// ignore count for this particular breakpoint is zero
- StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_tick_index];
+ StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
if (rts_stop_next_breakpoint == false && ignore_count > 0)
{
// decrement and write back ignore count
- ((StgInt*)breakPoints->payload)[arg4_tick_index] = --ignore_count;
+ ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
}
else if (rts_stop_next_breakpoint == true || ignore_count == 0)
{
@@ -1330,8 +1332,10 @@ run_BCO:
// continue execution of this BCO when the IO action returns.
//
// ioAction :: Addr# -- the breakpoint tick module
+ // -> Addr# -- the breakpoint tick module unit id
// -> Int# -- the breakpoint tick index
// -> Addr# -- the breakpoint info module
+ // -> Addr# -- the breakpoint info module unit id
// -> Int# -- the breakpoint info index
// -> Bool -- exception?
// -> HValue -- the AP_STACK, or exception
@@ -1340,17 +1344,21 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(15);
- SpW(14) = (W_)obj;
- SpW(13) = (W_)&stg_apply_interp_info;
- SpW(12) = (W_)new_aps;
- SpW(11) = (W_)False_closure; // True <=> an exception
- SpW(10) = (W_)&stg_ap_ppv_info;
- SpW(9) = (W_)arg5_info_index;
+ Sp_subW(19);
+ SpW(18) = (W_)obj;
+ SpW(17) = (W_)&stg_apply_interp_info;
+ SpW(16) = (W_)new_aps;
+ SpW(15) = (W_)False_closure; // True <=> an exception
+ SpW(14) = (W_)&stg_ap_ppv_info;
+ SpW(13) = (W_)arg7_info_index;
+ SpW(12) = (W_)&stg_ap_n_info;
+ SpW(11) = (W_)BCO_LIT(arg5_info_mod_id);
+ SpW(10) = (W_)&stg_ap_n_info;
+ SpW(9) = (W_)BCO_LIT(arg3_info_mod);
SpW(8) = (W_)&stg_ap_n_info;
- SpW(7) = (W_)BCO_LIT(arg3_info_mod);
+ SpW(7) = (W_)arg6_tick_index;
SpW(6) = (W_)&stg_ap_n_info;
- SpW(5) = (W_)arg4_tick_index;
+ SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id);
SpW(4) = (W_)&stg_ap_n_info;
SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
SpW(2) = (W_)&stg_ap_n_info;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91cb97034351a26f2162113a877ae27…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91cb97034351a26f2162113a877ae27…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-debugger-unitid] Add `UnitId`` to `EvalBreakpoint`
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-debugger-unitid at Glasgow Haskell Compiler / GHC
Commits:
31e01836 by fendor at 2025-04-17T14:22:27+02:00
Add `UnitId`` to `EvalBreakpoint`
The `EvalBreakpoint` is used to communicate that a breakpoint was
encountered during code evaluation.
This `EvalBreakpoint` needs to be converted to an `InternalBreakpointId`
which stores a `Module` to uniquely find the correct `Module` in the
Home Package Table.
The `EvalBreakpoint` used to store only a `ModuleName` which is then
converted to a `Module` based on the currently active home unit.
This is incorrect in the face of multiple home units, the break point
could be in an entirely other home unit!
To fix this, we additionally store the `UnitId` of the `Module` in
`EvalBreakpoint` to later reconstruct the correct `Module`
All of the changes are the consequence of extending `EvalBreakpoint`
with the additional `UnitId`.
- - - - -
11 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Exception.cmm
- rts/Interpreter.c
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -732,13 +732,16 @@ assembleI platform i = case i of
CCALL off m_addr i -> do np <- addr m_addr
emit_ bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit_ bci_PRIMCALL []
- BRK_FUN arr tick_mod tickx info_mod infox cc ->
+ BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc ->
do p1 <- ptr (BCOPtrBreakArray arr)
tick_addr <- addr tick_mod
+ tick_unitid_addr <- addr tick_mod_id
info_addr <- addr info_mod
+ info_unitid_addr <- addr info_mod_id
np <- addr cc
emit_ bci_BRK_FUN [ Op p1
, Op tick_addr, Op info_addr
+ , Op tick_unitid_addr, Op info_unitid_addr
, SmallOp tickx, SmallOp infox
, Op np
]
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
import Language.Haskell.Syntax.Module.Name (ModuleName)
import GHC.Types.Unique
+import GHC.Unit.Types (UnitId)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -233,8 +234,10 @@ data BCInstr
-- Breakpoints
| BRK_FUN (ForeignRef BreakArray)
(RemotePtr ModuleName) -- breakpoint tick module
+ (RemotePtr UnitId) -- breakpoint tick module unit id
!Word16 -- breakpoint tick index
(RemotePtr ModuleName) -- breakpoint info module
+ (RemotePtr UnitId) -- breakpoint info module unit id
!Word16 -- breakpoint info index
(RemotePtr CostCentre)
@@ -403,10 +406,10 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)
+ ppr (BRK_FUN _ _tick_mod _tick_mod_id tickx _info_mod _info_mod_id infox _)
= text "BRK_FUN" <+> text "<breakarray>"
- <+> text "<tick_module>" <+> ppr tickx
- <+> text "<info_module>" <+> ppr infox
+ <+> text "<tick_module>" <+> text "<tick_module_unitid>" <+> ppr tickx
+ <+> text "<info_module>" <+> text "<info_module_unitid>" <+> ppr infox
<+> text "<cc>"
#if MIN_VERSION_rts(1,0,3)
ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm)
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -50,6 +50,7 @@ import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
import GHC.Iface.Syntax
import Language.Haskell.Syntax.Module.Name (ModuleName)
+import GHC.Unit.Types (UnitId)
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -263,6 +264,9 @@ data ModBreaks
, modBreaks_breakInfo :: IntMap CgBreakInfo
-- ^ info about each breakpoint from the bytecode generator
, modBreaks_module :: RemotePtr ModuleName
+ -- ^ info about the module in which we are setting the breakpoint
+ , modBreaks_module_unitid :: RemotePtr UnitId
+ -- ^ The 'UnitId' of the 'ModuleName'
}
seqModBreaks :: ModBreaks -> ()
@@ -273,7 +277,8 @@ seqModBreaks ModBreaks{..} =
rnf modBreaks_decls `seq`
rnf modBreaks_ccs `seq`
rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`
- rnf modBreaks_module
+ rnf modBreaks_module `seq`
+ rnf modBreaks_module_unitid
-- | Construct an empty ModBreaks
emptyModBreaks :: ModBreaks
@@ -286,6 +291,7 @@ emptyModBreaks = ModBreaks
, modBreaks_ccs = array (0,-1) []
, modBreaks_breakInfo = IntMap.empty
, modBreaks_module = toRemotePtr nullPtr
+ , modBreaks_module_unitid = toRemotePtr nullPtr
}
{-
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -34,7 +34,7 @@ mkModBreaks interp mod extendedMixEntries
breakArray <- GHCi.newBreakArray interp count
ccs <- mkCCSArray interp mod count entries
- mod_ptr <- GHCi.newModuleName interp (moduleName mod)
+ (mod_ptr, mod_id_ptr) <- GHCi.newModule interp mod
let
locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
@@ -46,6 +46,7 @@ mkModBreaks interp mod extendedMixEntries
, modBreaks_decls = declsTicks
, modBreaks_ccs = ccs
, modBreaks_module = mod_ptr
+ , modBreaks_module_unitid = mod_id_ptr
}
mkCCSArray
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
-- 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
+ let ibi = evalBreakpointToId eval_break
tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi)
let
span = modBreaks_locs tick_brks ! ibi_tick_index ibi
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Runtime.Interpreter
, mkCostCentres
, costCentreStackInfo
, newBreakArray
- , newModuleName
+ , newModule
, storeBreakpoint
, breakpointStatus
, getBreakpointVar
@@ -93,9 +93,7 @@ import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)
import GHC.Utils.Fingerprint
import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo
-import GHC.Unit.Home.PackageTable
import GHC.Unit.Env
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -119,6 +117,7 @@ import qualified GHC.InfoProv as InfoProv
import GHC.Builtin.Names
import GHC.Types.Name
+import qualified GHC.Unit.Home.Graph as HUG
-- Standard libraries
import GHC.Exts
@@ -377,9 +376,13 @@ newBreakArray interp size = do
breakArray <- interpCmd interp (NewBreakArray size)
mkFinalizedHValue interp breakArray
-newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
-newModuleName interp mod_name =
- castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name))
+newModule :: Interp -> Module -> IO (RemotePtr ModuleName, RemotePtr UnitId)
+newModule interp mod = do
+ let
+ mod_name = moduleNameString $ moduleName mod
+ mod_id = unitIdString $ toUnitId $ moduleUnit mod
+ (mod_ptr, mod_id_ptr) <- interpCmd interp (NewBreakModule mod_name mod_id)
+ pure (castRemotePtr mod_ptr, castRemotePtr mod_id_ptr)
storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
storeBreakpoint interp ref ix cnt = do -- #19157
@@ -415,19 +418,21 @@ seqHValue interp unit_env ref =
status <- interpCmd interp (Seq hval)
handleSeqHValueStatus interp unit_env status
-evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> IO InternalBreakpointId
-evalBreakpointToId hpt eval_break =
- let load_mod x = mi_module . hm_iface . expectJust <$> lookupHpt hpt (mkModuleName x)
- in do
- tickl <- load_mod (eb_tick_mod eval_break)
- infol <- load_mod (eb_info_mod eval_break)
- return
- InternalBreakpointId
- { ibi_tick_mod = tickl
- , ibi_tick_index = eb_tick_index eval_break
- , ibi_info_mod = infol
- , ibi_info_index = eb_info_index eval_break
- }
+evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
+evalBreakpointToId eval_break =
+ let
+ mkUnitId u = RealUnit (Definite $ stringToUnitId u)
+
+ toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break)
+ infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
+ in
+ InternalBreakpointId
+ { ibi_tick_mod = tickl
+ , ibi_tick_index = eb_tick_index eval_break
+ , ibi_info_mod = infol
+ , ibi_info_index = eb_info_index eval_break
+ }
-- | Process the result of a Seq or ResumeSeq message. #2950
handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
@@ -447,12 +452,12 @@ handleSeqHValueStatus interp unit_env eval_status =
mkGeneralSrcSpan (fsLit "<unknown>")
Just break -> do
- bi <- evalBreakpointToId (ue_hpt unit_env) break
+ let bi = evalBreakpointToId break
-- Just case: Stopped at a breakpoint, extract SrcSpan information
-- from the breakpoint.
breaks_tick <- getModBreaks . expectJust <$>
- lookupHpt (ue_hpt unit_env) (moduleName (ibi_tick_mod bi))
+ HUG.lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
put $ brackets . ppr $
(modBreaks_locs breaks_tick) ! ibi_tick_index bi
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -416,7 +416,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
Nothing -> pure code
Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case
Nothing -> pure code
- Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do
+ Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_module_unitid = tick_mod_id_ptr, modBreaks_ccs = cc_arr} -> do
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
@@ -425,6 +425,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
let info_mod_ptr = modBreaks_module current_mod_breaks
+ info_mod_id_ptr = modBreaks_module_unitid current_mod_breaks
infox <- newBreakInfo breakInfo
let cc | Just interp <- hsc_interp hsc_env
@@ -437,7 +438,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
in if fromIntegral r == x
then r
else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
- breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc
+ breakInstr = BRK_FUN breaks tick_mod_ptr tick_mod_id_ptr (toW16 tick_no) info_mod_ptr info_mod_id_ptr (toW16 infox) cc
return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -23,6 +23,7 @@ module GHCi.Message
, getMessage, putMessage, getTHMessage, putTHMessage
, Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe
, BreakModule
+ , BreakUnitId
, LoadedDLL
) where
@@ -245,8 +246,9 @@ data Message a where
-- | Allocate a string for a breakpoint module name.
-- This uses an empty dummy type because @ModuleName@ isn't available here.
NewBreakModule
- :: String
- -> Message (RemotePtr BreakModule)
+ :: String -- ^ @ModuleName@
+ -> String -- ^ @UnitId@ for the given @ModuleName@
+ -> Message (RemotePtr BreakModule, RemotePtr BreakUnitId)
deriving instance Show (Message a)
@@ -410,10 +412,12 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_tick_mod :: String -- ^ Breakpoint tick module
- , eb_tick_index :: Int -- ^ Breakpoint tick index
- , eb_info_mod :: String -- ^ Breakpoint info module
- , eb_info_index :: Int -- ^ Breakpoint info index
+ { eb_tick_mod :: String -- ^ Breakpoint tick module
+ , eb_tick_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_tick_index :: Int -- ^ Breakpoint tick index
+ , eb_info_mod :: String -- ^ Breakpoint info module
+ , eb_info_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_info_index :: Int -- ^ Breakpoint info index
}
deriving (Generic, Show)
@@ -430,6 +434,10 @@ instance Binary a => Binary (EvalResult a)
-- that type isn't available here.
data BreakModule
+-- | A dummy type that tags the pointer to a breakpoint's @UnitId@, because
+-- that type isn't available here.
+data BreakUnitId
+
-- | A dummy type that tags pointers returned by 'LoadDLL'.
data LoadedDLL
@@ -580,7 +588,7 @@ getMessage = do
36 -> Msg <$> (Seq <$> get)
37 -> Msg <$> return RtsRevertCAFs
38 -> Msg <$> (ResumeSeq <$> get)
- 39 -> Msg <$> (NewBreakModule <$> get)
+ 39 -> Msg <$> (NewBreakModule <$> get <*> get)
40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
41 -> Msg <$> (WhereFrom <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
@@ -627,7 +635,7 @@ putMessage m = case m of
Seq a -> putWord8 36 >> put a
RtsRevertCAFs -> putWord8 37
ResumeSeq a -> putWord8 38 >> put a
- NewBreakModule name -> putWord8 39 >> put name
+ NewBreakModule name unitid -> putWord8 39 >> put name >> put unitid
LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str
WhereFrom a -> putWord8 41 >> put a
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -95,7 +95,10 @@ run m = case m of
MkCostCentres mod ccs -> mkCostCentres mod ccs
CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
- NewBreakModule name -> newModuleName name
+ NewBreakModule name unitid -> do
+ namePtr <- newModuleName name
+ uidPtr <- newUnitId unitid
+ pure (namePtr, uidPtr)
SetupBreakpoint ref ix cnt -> do
arr <- localRef ref;
_ <- setupBreakpoint arr ix cnt
@@ -335,7 +338,7 @@ withBreakAction opts breakMVar statusMVar act
-- as soon as it is hit, or in resetBreakAction below.
onBreak :: BreakpointCallback
- onBreak tick_mod# tickx# info_mod# infox# is_exception apStack = do
+ onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do
tid <- myThreadId
let resume = ResumeContext
{ resumeBreakMVar = breakMVar
@@ -349,8 +352,10 @@ withBreakAction opts breakMVar statusMVar act
then pure Nothing
else do
tick_mod <- peekCString (Ptr tick_mod#)
+ tick_mod_uid <- peekCString (Ptr tick_mod_uid#)
info_mod <- peekCString (Ptr info_mod#)
- pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#)))
+ info_mod_uid <- peekCString (Ptr info_mod_uid#)
+ pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
takeMVar breakMVar
@@ -400,8 +405,10 @@ resetStepFlag = poke stepFlag 0
type BreakpointCallback
= Addr# -- pointer to the breakpoint tick module name
+ -> Addr# -- pointer to the breakpoint tick module unit id
-> Int# -- breakpoint tick index
-> Addr# -- pointer to the breakpoint info module name
+ -> Addr# -- pointer to the breakpoint info module unit id
-> Int# -- breakpoint info index
-> Bool -- exception?
-> HValue -- the AP_STACK, or exception
@@ -414,8 +421,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: BreakpointCallback
-noBreakAction _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction _ _ _ _ True _ = return () -- exception: just continue
+noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue
-- Malloc and copy the bytes. We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
@@ -453,6 +460,10 @@ newModuleName :: String -> IO (RemotePtr BreakModule)
newModuleName name =
castRemotePtr . toRemotePtr <$> newCString name
+newUnitId :: String -> IO (RemotePtr BreakUnitId)
+newUnitId name =
+ castRemotePtr . toRemotePtr <$> newCString name
+
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
case getApStackVal# apStack stackDepth of
=====================================
rts/Exception.cmm
=====================================
@@ -535,12 +535,16 @@ retry_pop_stack:
// be per-thread.
CInt[rts_stop_on_exception] = 0;
("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
- Sp = Sp - WDS(13);
- Sp(12) = exception;
- Sp(11) = stg_raise_ret_info;
- Sp(10) = exception;
- Sp(9) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
- Sp(8) = stg_ap_ppv_info;
+ Sp = Sp - WDS(17);
+ Sp(16) = exception;
+ Sp(15) = stg_raise_ret_info;
+ Sp(14) = exception;
+ Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
+ Sp(12) = stg_ap_ppv_info;
+ Sp(11) = 0;
+ Sp(10) = stg_ap_n_info;
+ Sp(9) = 0;
+ Sp(8) = stg_ap_n_info;
Sp(7) = 0;
Sp(6) = stg_ap_n_info;
Sp(5) = 0;
=====================================
rts/Interpreter.c
=====================================
@@ -1245,9 +1245,9 @@ run_BCO:
/* check for a breakpoint on the beginning of a let binding */
case bci_BRK_FUN:
{
- int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_index, arg5_info_index;
+ int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index;
#if defined(PROFILING)
- int arg6_cc;
+ int arg8_cc;
#endif
StgArrBytes *breakPoints;
int returning_from_break;
@@ -1264,10 +1264,12 @@ run_BCO:
arg1_brk_array = BCO_GET_LARGE_ARG;
arg2_tick_mod = BCO_GET_LARGE_ARG;
arg3_info_mod = BCO_GET_LARGE_ARG;
- arg4_tick_index = BCO_NEXT;
- arg5_info_index = BCO_NEXT;
+ arg4_tick_mod_id = BCO_GET_LARGE_ARG;
+ arg5_info_mod_id = BCO_GET_LARGE_ARG;
+ arg6_tick_index = BCO_NEXT;
+ arg7_info_index = BCO_NEXT;
#if defined(PROFILING)
- arg6_cc = BCO_GET_LARGE_ARG;
+ arg8_cc = BCO_GET_LARGE_ARG;
#else
BCO_GET_LARGE_ARG;
#endif
@@ -1280,7 +1282,7 @@ run_BCO:
#if defined(PROFILING)
cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
- (CostCentre*)BCO_LIT(arg6_cc));
+ (CostCentre*)BCO_LIT(arg8_cc));
#endif
// if we are returning from a break then skip this section
@@ -1292,11 +1294,11 @@ run_BCO:
// stop the current thread if either the
// "rts_stop_next_breakpoint" flag is true OR if the
// ignore count for this particular breakpoint is zero
- StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_tick_index];
+ StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
if (rts_stop_next_breakpoint == false && ignore_count > 0)
{
// decrement and write back ignore count
- ((StgInt*)breakPoints->payload)[arg4_tick_index] = --ignore_count;
+ ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
}
else if (rts_stop_next_breakpoint == true || ignore_count == 0)
{
@@ -1330,8 +1332,10 @@ run_BCO:
// continue execution of this BCO when the IO action returns.
//
// ioAction :: Addr# -- the breakpoint tick module
+ // -> Addr# -- the breakpoint tick module unit id
// -> Int# -- the breakpoint tick index
// -> Addr# -- the breakpoint info module
+ // -> Addr# -- the breakpoint info module unit id
// -> Int# -- the breakpoint info index
// -> Bool -- exception?
// -> HValue -- the AP_STACK, or exception
@@ -1340,17 +1344,21 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(15);
- SpW(14) = (W_)obj;
- SpW(13) = (W_)&stg_apply_interp_info;
- SpW(12) = (W_)new_aps;
- SpW(11) = (W_)False_closure; // True <=> an exception
- SpW(10) = (W_)&stg_ap_ppv_info;
- SpW(9) = (W_)arg5_info_index;
+ Sp_subW(19);
+ SpW(18) = (W_)obj;
+ SpW(17) = (W_)&stg_apply_interp_info;
+ SpW(16) = (W_)new_aps;
+ SpW(15) = (W_)False_closure; // True <=> an exception
+ SpW(14) = (W_)&stg_ap_ppv_info;
+ SpW(13) = (W_)arg7_info_index;
+ SpW(12) = (W_)&stg_ap_n_info;
+ SpW(11) = (W_)BCO_LIT(arg5_info_mod_id);
+ SpW(10) = (W_)&stg_ap_n_info;
+ SpW(9) = (W_)BCO_LIT(arg3_info_mod);
SpW(8) = (W_)&stg_ap_n_info;
- SpW(7) = (W_)BCO_LIT(arg3_info_mod);
+ SpW(7) = (W_)arg6_tick_index;
SpW(6) = (W_)&stg_ap_n_info;
- SpW(5) = (W_)arg4_tick_index;
+ SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id);
SpW(4) = (W_)&stg_ap_n_info;
SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
SpW(2) = (W_)&stg_ap_n_info;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31e01836fd194e369a73a0f287c58fb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31e01836fd194e369a73a0f287c58fb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC
Commits:
bc27b6c9 by Simon Peyton Jones at 2025-04-17T13:12:48+01:00
More eperiments
* Don't inline toplevel things so much
* Don't float constants so vigorously in the first float-out
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1096,14 +1096,14 @@ mkNonRecRhsCtxt lvl bndr unf
certainly_inline -- See Note [Cascading inlines]
= -- mkNonRecRhsCtxt is only used for non-join points, so occAnalBind
-- has set the OccInfo for this binder before calling occAnalNonRecRhs
+ -- Distressing delicacy ... has to line up with preInlineUnconditionally
case idOccInfo bndr of
OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }
- -> active && not stable_unf && not top_bottoming
+ -> active && not (isTopLevel lvl) && not stable_unf
_ -> False
active = isAlwaysActive (idInlineActivation bndr)
stable_unf = isStableUnfolding unf
- top_bottoming = isTopLevel lvl && isDeadEndId bndr
-----------------
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -217,7 +217,7 @@ getCoreToDo dflags hpt_rule_base extra_vars
if full_laziness then
CoreDoFloatOutwards $ FloatOutSwitches
{ floatOutLambdas = Just 0
- , floatOutConstants = True
+ , floatOutConstants = False -- Initially
, floatOutOverSatApps = False
, floatToTopLevelOnly = False
, floatJoinsToTop = False -- Initially, don't float join points at all
@@ -284,7 +284,7 @@ getCoreToDo dflags hpt_rule_base extra_vars
-- f_el22 (f_el21 r_midblock)
runWhen full_laziness $ CoreDoFloatOutwards $ FloatOutSwitches
{ floatOutLambdas = floatLamArgs dflags
- , floatOutConstants = True
+ , floatOutConstants = True -- For SpecConstr and CSE
, floatOutOverSatApps = True
, floatToTopLevelOnly = False
, floatJoinsToTop = True },
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1461,12 +1461,18 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
one_occ IAmDead = True -- Happens in ((\x.1) v)
- one_occ OneOcc{ occ_n_br = 1
- , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase
+ one_occ OneOcc{ occ_n_br = 1
+ , occ_in_lam = NotInsideLam
+ , occ_int_cxt = int_cxt }
+ = isNotTopLevel top_lvl -- Get rid of allocation
+ || (int_cxt==IsInteresting) -- Function is applied
+ || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase
one_occ OneOcc{ occ_n_br = 1
, occ_in_lam = IsInsideLam
- , occ_int_cxt = IsInteresting } = canInlineInLam rhs
- one_occ _ = False
+ , occ_int_cxt = IsInteresting }
+ = canInlineInLam rhs
+ one_occ _
+ = False
pre_inline_unconditionally = sePreInline env
active = isActive (sePhase env) (inlinePragmaActivation inline_prag)
@@ -1641,9 +1647,10 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs
| otherwise = smallEnoughToInline uf_opts unfolding
-- See Note [Post-inline for single-use things]
- check_one_occ NotInsideLam _ n_br = code_dup_ok n_br
- check_one_occ IsInsideLam NotInteresting _ = False
- check_one_occ IsInsideLam IsInteresting n_br = is_cheap && code_dup_ok n_br
+ check_one_occ NotInsideLam NotInteresting n_br = not is_top_lvl && code_dup_ok n_br
+ check_one_occ NotInsideLam IsInteresting n_br = code_dup_ok n_br
+ check_one_occ IsInsideLam NotInteresting _ = False
+ check_one_occ IsInsideLam IsInteresting n_br = is_cheap && code_dup_ok n_br
-- IsInteresting: inlining inside a lambda only with good reason
-- See the notes on int_cxt in preInlineUnconditionally
-- is_cheap: check for acceptable work duplication, using isCheapUnfolding
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc27b6c9b536a8200cd2b8750e4744f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc27b6c9b536a8200cd2b8750e4744f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/fendor/ghci-debugger-unitid
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed new branch wip/fendor/ghci-debugger-unitid at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/ghci-debugger-unitid
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units-with-debugger] Make GHCi debugger compatible with multiple home units
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units-with-debugger at Glasgow Haskell Compiler / GHC
Commits:
f071532b by fendor at 2025-04-17T13:33:14+02:00
Make GHCi debugger compatible with multiple home units
FIXME: proper commit message
- - - - -
11 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Exception.cmm
- rts/Interpreter.c
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -732,13 +732,16 @@ assembleI platform i = case i of
CCALL off m_addr i -> do np <- addr m_addr
emit_ bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit_ bci_PRIMCALL []
- BRK_FUN arr tick_mod tickx info_mod infox cc ->
+ BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc ->
do p1 <- ptr (BCOPtrBreakArray arr)
tick_addr <- addr tick_mod
+ tick_unitid_addr <- addr tick_mod_id
info_addr <- addr info_mod
+ info_unitid_addr <- addr info_mod_id
np <- addr cc
emit_ bci_BRK_FUN [ Op p1
, Op tick_addr, Op info_addr
+ , Op tick_unitid_addr, Op info_unitid_addr
, SmallOp tickx, SmallOp infox
, Op np
]
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
import Language.Haskell.Syntax.Module.Name (ModuleName)
import GHC.Types.Unique
+import GHC.Unit.Types (UnitId)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -233,8 +234,10 @@ data BCInstr
-- Breakpoints
| BRK_FUN (ForeignRef BreakArray)
(RemotePtr ModuleName) -- breakpoint tick module
+ (RemotePtr UnitId) -- breakpoint tick module unit id
!Word16 -- breakpoint tick index
(RemotePtr ModuleName) -- breakpoint info module
+ (RemotePtr UnitId) -- breakpoint info module unit id
!Word16 -- breakpoint info index
(RemotePtr CostCentre)
@@ -403,10 +406,10 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)
+ ppr (BRK_FUN _ _tick_mod _tick_mod_id tickx _info_mod _info_mod_id infox _)
= text "BRK_FUN" <+> text "<breakarray>"
- <+> text "<tick_module>" <+> ppr tickx
- <+> text "<info_module>" <+> ppr infox
+ <+> text "<tick_module>" <+> text "<tick_module_unitid>" <+> ppr tickx
+ <+> text "<info_module>" <+> text "<info_module_unitid>" <+> ppr infox
<+> text "<cc>"
#if MIN_VERSION_rts(1,0,3)
ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm)
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -50,6 +50,7 @@ import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
import GHC.Iface.Syntax
import Language.Haskell.Syntax.Module.Name (ModuleName)
+import GHC.Unit.Types (UnitId)
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -263,6 +264,9 @@ data ModBreaks
, modBreaks_breakInfo :: IntMap CgBreakInfo
-- ^ info about each breakpoint from the bytecode generator
, modBreaks_module :: RemotePtr ModuleName
+ -- ^ info about the module in which we are setting the breakpoint
+ , modBreaks_module_unitid :: RemotePtr UnitId
+ -- ^ The 'UnitId' of the 'ModuleName'
}
seqModBreaks :: ModBreaks -> ()
@@ -273,7 +277,8 @@ seqModBreaks ModBreaks{..} =
rnf modBreaks_decls `seq`
rnf modBreaks_ccs `seq`
rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`
- rnf modBreaks_module
+ rnf modBreaks_module `seq`
+ rnf modBreaks_module_unitid
-- | Construct an empty ModBreaks
emptyModBreaks :: ModBreaks
@@ -286,6 +291,7 @@ emptyModBreaks = ModBreaks
, modBreaks_ccs = array (0,-1) []
, modBreaks_breakInfo = IntMap.empty
, modBreaks_module = toRemotePtr nullPtr
+ , modBreaks_module_unitid = toRemotePtr nullPtr
}
{-
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -34,7 +34,7 @@ mkModBreaks interp mod extendedMixEntries
breakArray <- GHCi.newBreakArray interp count
ccs <- mkCCSArray interp mod count entries
- mod_ptr <- GHCi.newModuleName interp (moduleName mod)
+ (mod_ptr, mod_id_ptr) <- GHCi.newModule interp mod
let
locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
@@ -46,6 +46,7 @@ mkModBreaks interp mod extendedMixEntries
, modBreaks_decls = declsTicks
, modBreaks_ccs = ccs
, modBreaks_module = mod_ptr
+ , modBreaks_module_unitid = mod_id_ptr
}
mkCCSArray
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
-- 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
+ let ibi = evalBreakpointToId eval_break
tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi)
let
span = modBreaks_locs tick_brks ! ibi_tick_index ibi
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Runtime.Interpreter
, mkCostCentres
, costCentreStackInfo
, newBreakArray
- , newModuleName
+ , newModule
, storeBreakpoint
, breakpointStatus
, getBreakpointVar
@@ -93,9 +93,7 @@ import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)
import GHC.Utils.Fingerprint
import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo
-import GHC.Unit.Home.PackageTable
import GHC.Unit.Env
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -119,6 +117,7 @@ import qualified GHC.InfoProv as InfoProv
import GHC.Builtin.Names
import GHC.Types.Name
+import qualified GHC.Unit.Home.Graph as HUG
-- Standard libraries
import GHC.Exts
@@ -377,9 +376,13 @@ newBreakArray interp size = do
breakArray <- interpCmd interp (NewBreakArray size)
mkFinalizedHValue interp breakArray
-newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
-newModuleName interp mod_name =
- castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name))
+newModule :: Interp -> Module -> IO (RemotePtr ModuleName, RemotePtr UnitId)
+newModule interp mod = do
+ let
+ mod_name = moduleNameString $ moduleName mod
+ mod_id = unitIdString $ toUnitId $ moduleUnit mod
+ (mod_ptr, mod_id_ptr) <- interpCmd interp (NewBreakModule mod_name mod_id)
+ pure (castRemotePtr mod_ptr, castRemotePtr mod_id_ptr)
storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
storeBreakpoint interp ref ix cnt = do -- #19157
@@ -415,19 +418,21 @@ seqHValue interp unit_env ref =
status <- interpCmd interp (Seq hval)
handleSeqHValueStatus interp unit_env status
-evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> IO InternalBreakpointId
-evalBreakpointToId hpt eval_break =
- let load_mod x = mi_module . hm_iface . expectJust <$> lookupHpt hpt (mkModuleName x)
- in do
- tickl <- load_mod (eb_tick_mod eval_break)
- infol <- load_mod (eb_info_mod eval_break)
- return
- InternalBreakpointId
- { ibi_tick_mod = tickl
- , ibi_tick_index = eb_tick_index eval_break
- , ibi_info_mod = infol
- , ibi_info_index = eb_info_index eval_break
- }
+evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
+evalBreakpointToId eval_break =
+ let
+ mkUnitId u = RealUnit (Definite $ stringToUnitId u)
+
+ toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break)
+ infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
+ in
+ InternalBreakpointId
+ { ibi_tick_mod = tickl
+ , ibi_tick_index = eb_tick_index eval_break
+ , ibi_info_mod = infol
+ , ibi_info_index = eb_info_index eval_break
+ }
-- | Process the result of a Seq or ResumeSeq message. #2950
handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
@@ -447,12 +452,12 @@ handleSeqHValueStatus interp unit_env eval_status =
mkGeneralSrcSpan (fsLit "<unknown>")
Just break -> do
- bi <- evalBreakpointToId (ue_hpt unit_env) break
+ let bi = evalBreakpointToId break
-- Just case: Stopped at a breakpoint, extract SrcSpan information
-- from the breakpoint.
breaks_tick <- getModBreaks . expectJust <$>
- lookupHpt (ue_hpt unit_env) (moduleName (ibi_tick_mod bi))
+ HUG.lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
put $ brackets . ppr $
(modBreaks_locs breaks_tick) ! ibi_tick_index bi
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -416,7 +416,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
Nothing -> pure code
Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case
Nothing -> pure code
- Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do
+ Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_module_unitid = tick_mod_id_ptr, modBreaks_ccs = cc_arr} -> do
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
@@ -425,6 +425,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
let info_mod_ptr = modBreaks_module current_mod_breaks
+ info_mod_id_ptr = modBreaks_module_unitid current_mod_breaks
infox <- newBreakInfo breakInfo
let cc | Just interp <- hsc_interp hsc_env
@@ -437,7 +438,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
in if fromIntegral r == x
then r
else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
- breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc
+ breakInstr = BRK_FUN breaks tick_mod_ptr tick_mod_id_ptr (toW16 tick_no) info_mod_ptr info_mod_id_ptr (toW16 infox) cc
return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -23,6 +23,7 @@ module GHCi.Message
, getMessage, putMessage, getTHMessage, putTHMessage
, Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe
, BreakModule
+ , BreakUnitId
, LoadedDLL
) where
@@ -245,8 +246,9 @@ data Message a where
-- | Allocate a string for a breakpoint module name.
-- This uses an empty dummy type because @ModuleName@ isn't available here.
NewBreakModule
- :: String
- -> Message (RemotePtr BreakModule)
+ :: String -- ^ @ModuleName@
+ -> String -- ^ @UnitId@ for the given @ModuleName@
+ -> Message (RemotePtr BreakModule, RemotePtr BreakUnitId)
deriving instance Show (Message a)
@@ -410,10 +412,12 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_tick_mod :: String -- ^ Breakpoint tick module
- , eb_tick_index :: Int -- ^ Breakpoint tick index
- , eb_info_mod :: String -- ^ Breakpoint info module
- , eb_info_index :: Int -- ^ Breakpoint info index
+ { eb_tick_mod :: String -- ^ Breakpoint tick module
+ , eb_tick_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_tick_index :: Int -- ^ Breakpoint tick index
+ , eb_info_mod :: String -- ^ Breakpoint info module
+ , eb_info_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_info_index :: Int -- ^ Breakpoint info index
}
deriving (Generic, Show)
@@ -430,6 +434,10 @@ instance Binary a => Binary (EvalResult a)
-- that type isn't available here.
data BreakModule
+-- | A dummy type that tags the pointer to a breakpoint's @UnitId@, because
+-- that type isn't available here.
+data BreakUnitId
+
-- | A dummy type that tags pointers returned by 'LoadDLL'.
data LoadedDLL
@@ -580,7 +588,7 @@ getMessage = do
36 -> Msg <$> (Seq <$> get)
37 -> Msg <$> return RtsRevertCAFs
38 -> Msg <$> (ResumeSeq <$> get)
- 39 -> Msg <$> (NewBreakModule <$> get)
+ 39 -> Msg <$> (NewBreakModule <$> get <*> get)
40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
41 -> Msg <$> (WhereFrom <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
@@ -627,7 +635,7 @@ putMessage m = case m of
Seq a -> putWord8 36 >> put a
RtsRevertCAFs -> putWord8 37
ResumeSeq a -> putWord8 38 >> put a
- NewBreakModule name -> putWord8 39 >> put name
+ NewBreakModule name unitid -> putWord8 39 >> put name >> put unitid
LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str
WhereFrom a -> putWord8 41 >> put a
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -95,7 +95,10 @@ run m = case m of
MkCostCentres mod ccs -> mkCostCentres mod ccs
CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
- NewBreakModule name -> newModuleName name
+ NewBreakModule name unitid -> do
+ namePtr <- newModuleName name
+ uidPtr <- newUnitId unitid
+ pure (namePtr, uidPtr)
SetupBreakpoint ref ix cnt -> do
arr <- localRef ref;
_ <- setupBreakpoint arr ix cnt
@@ -335,7 +338,7 @@ withBreakAction opts breakMVar statusMVar act
-- as soon as it is hit, or in resetBreakAction below.
onBreak :: BreakpointCallback
- onBreak tick_mod# tickx# info_mod# infox# is_exception apStack = do
+ onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do
tid <- myThreadId
let resume = ResumeContext
{ resumeBreakMVar = breakMVar
@@ -349,8 +352,10 @@ withBreakAction opts breakMVar statusMVar act
then pure Nothing
else do
tick_mod <- peekCString (Ptr tick_mod#)
+ tick_mod_uid <- peekCString (Ptr tick_mod_uid#)
info_mod <- peekCString (Ptr info_mod#)
- pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#)))
+ info_mod_uid <- peekCString (Ptr info_mod_uid#)
+ pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
takeMVar breakMVar
@@ -400,8 +405,10 @@ resetStepFlag = poke stepFlag 0
type BreakpointCallback
= Addr# -- pointer to the breakpoint tick module name
+ -> Addr# -- pointer to the breakpoint tick module unit id
-> Int# -- breakpoint tick index
-> Addr# -- pointer to the breakpoint info module name
+ -> Addr# -- pointer to the breakpoint info module unit id
-> Int# -- breakpoint info index
-> Bool -- exception?
-> HValue -- the AP_STACK, or exception
@@ -414,8 +421,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: BreakpointCallback
-noBreakAction _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction _ _ _ _ True _ = return () -- exception: just continue
+noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue
-- Malloc and copy the bytes. We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
@@ -453,6 +460,10 @@ newModuleName :: String -> IO (RemotePtr BreakModule)
newModuleName name =
castRemotePtr . toRemotePtr <$> newCString name
+newUnitId :: String -> IO (RemotePtr BreakUnitId)
+newUnitId name =
+ castRemotePtr . toRemotePtr <$> newCString name
+
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
case getApStackVal# apStack stackDepth of
=====================================
rts/Exception.cmm
=====================================
@@ -535,12 +535,16 @@ retry_pop_stack:
// be per-thread.
CInt[rts_stop_on_exception] = 0;
("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
- Sp = Sp - WDS(13);
- Sp(12) = exception;
- Sp(11) = stg_raise_ret_info;
- Sp(10) = exception;
- Sp(9) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
- Sp(8) = stg_ap_ppv_info;
+ Sp = Sp - WDS(17);
+ Sp(16) = exception;
+ Sp(15) = stg_raise_ret_info;
+ Sp(14) = exception;
+ Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
+ Sp(12) = stg_ap_ppv_info;
+ Sp(11) = 0;
+ Sp(10) = stg_ap_n_info;
+ Sp(9) = 0;
+ Sp(8) = stg_ap_n_info;
Sp(7) = 0;
Sp(6) = stg_ap_n_info;
Sp(5) = 0;
=====================================
rts/Interpreter.c
=====================================
@@ -1245,9 +1245,9 @@ run_BCO:
/* check for a breakpoint on the beginning of a let binding */
case bci_BRK_FUN:
{
- int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_index, arg5_info_index;
+ int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index;
#if defined(PROFILING)
- int arg6_cc;
+ int arg8_cc;
#endif
StgArrBytes *breakPoints;
int returning_from_break;
@@ -1264,10 +1264,12 @@ run_BCO:
arg1_brk_array = BCO_GET_LARGE_ARG;
arg2_tick_mod = BCO_GET_LARGE_ARG;
arg3_info_mod = BCO_GET_LARGE_ARG;
- arg4_tick_index = BCO_NEXT;
- arg5_info_index = BCO_NEXT;
+ arg4_tick_mod_id = BCO_GET_LARGE_ARG;
+ arg5_info_mod_id = BCO_GET_LARGE_ARG;
+ arg6_tick_index = BCO_NEXT;
+ arg7_info_index = BCO_NEXT;
#if defined(PROFILING)
- arg6_cc = BCO_GET_LARGE_ARG;
+ arg8_cc = BCO_GET_LARGE_ARG;
#else
BCO_GET_LARGE_ARG;
#endif
@@ -1280,7 +1282,7 @@ run_BCO:
#if defined(PROFILING)
cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
- (CostCentre*)BCO_LIT(arg6_cc));
+ (CostCentre*)BCO_LIT(arg8_cc));
#endif
// if we are returning from a break then skip this section
@@ -1292,11 +1294,11 @@ run_BCO:
// stop the current thread if either the
// "rts_stop_next_breakpoint" flag is true OR if the
// ignore count for this particular breakpoint is zero
- StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_tick_index];
+ StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
if (rts_stop_next_breakpoint == false && ignore_count > 0)
{
// decrement and write back ignore count
- ((StgInt*)breakPoints->payload)[arg4_tick_index] = --ignore_count;
+ ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
}
else if (rts_stop_next_breakpoint == true || ignore_count == 0)
{
@@ -1330,8 +1332,10 @@ run_BCO:
// continue execution of this BCO when the IO action returns.
//
// ioAction :: Addr# -- the breakpoint tick module
+ // -> Addr# -- the breakpoint tick module unit id
// -> Int# -- the breakpoint tick index
// -> Addr# -- the breakpoint info module
+ // -> Addr# -- the breakpoint info module unit id
// -> Int# -- the breakpoint info index
// -> Bool -- exception?
// -> HValue -- the AP_STACK, or exception
@@ -1340,17 +1344,21 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(15);
- SpW(14) = (W_)obj;
- SpW(13) = (W_)&stg_apply_interp_info;
- SpW(12) = (W_)new_aps;
- SpW(11) = (W_)False_closure; // True <=> an exception
- SpW(10) = (W_)&stg_ap_ppv_info;
- SpW(9) = (W_)arg5_info_index;
+ Sp_subW(19);
+ SpW(18) = (W_)obj;
+ SpW(17) = (W_)&stg_apply_interp_info;
+ SpW(16) = (W_)new_aps;
+ SpW(15) = (W_)False_closure; // True <=> an exception
+ SpW(14) = (W_)&stg_ap_ppv_info;
+ SpW(13) = (W_)arg7_info_index;
+ SpW(12) = (W_)&stg_ap_n_info;
+ SpW(11) = (W_)BCO_LIT(arg5_info_mod_id);
+ SpW(10) = (W_)&stg_ap_n_info;
+ SpW(9) = (W_)BCO_LIT(arg3_info_mod);
SpW(8) = (W_)&stg_ap_n_info;
- SpW(7) = (W_)BCO_LIT(arg3_info_mod);
+ SpW(7) = (W_)arg6_tick_index;
SpW(6) = (W_)&stg_ap_n_info;
- SpW(5) = (W_)arg4_tick_index;
+ SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id);
SpW(4) = (W_)&stg_ap_n_info;
SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
SpW(2) = (W_)&stg_ap_n_info;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f071532b8f1b11ef4a09989f879d8fb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f071532b8f1b11ef4a09989f879d8fb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 3 commits: ghci: Use loadInterfaceForModule rather than loadSrcInterface in mkTopLevEnv
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC
Commits:
259ab6b7 by Matthew Pickering at 2025-04-17T13:30:37+02:00
ghci: Use loadInterfaceForModule rather than loadSrcInterface in mkTopLevEnv
loadSrcInterface takes a user given `ModuleName` and resolves it to the
module which needs to be loaded (taking into account module
renaming/visibility etc).
loadInterfaceForModule takes a specific module and loads it.
The modules in `ImpDeclSpec` have already been resolved to the actual
module to get the information from during renaming. Therefore we just
need to fetch the precise interface from disk (and not attempt to rename
it again).
Fixes #25951
- - - - -
368a358b by fendor at 2025-04-17T13:30:37+02:00
Make GHCi commands compatible with multiple home units
FIXME: proper commit message
- - - - -
f56a7898 by fendor at 2025-04-17T13:30:37+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.
- - - - -
35 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Types.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- testsuite/driver/testlib.py
- + testsuite/tests/ghci/prog-mhu001/Makefile
- + testsuite/tests/ghci/prog-mhu001/e/E.hs
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001.T
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001.stdout
- + testsuite/tests/ghci/prog-mhu001/unitE
- + testsuite/tests/ghci/prog-mhu002/Makefile
- + testsuite/tests/ghci/prog-mhu002/a/A.hs
- + 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-mhu002.T
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002.stderr
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002.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/scripts/GhciPackageRename.hs
- + testsuite/tests/ghci/scripts/GhciPackageRename.script
- + testsuite/tests/ghci/scripts/GhciPackageRename.stdout
- testsuite/tests/ghci/scripts/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e0b1649b2ca60207aa57e144af655…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e0b1649b2ca60207aa57e144af655…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/interpreter_primops] Fix some macros.
by Andreas Klebinger (＠AndreasK) 17 Apr '25
by Andreas Klebinger (＠AndreasK) 17 Apr '25
17 Apr '25
Andreas Klebinger pushed to branch wip/andreask/interpreter_primops at Glasgow Haskell Compiler / GHC
Commits:
69ac44b9 by Andreas Klebinger at 2025-04-17T13:26:53+02:00
Fix some macros.
- - - - -
1 changed file:
- rts/Interpreter.c
Changes:
=====================================
rts/Interpreter.c
=====================================
@@ -199,11 +199,11 @@ See also Note [Width of parameters] for some more motivation.
(RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame))))
-#define WDS_TO_W64(n) (n * sizeof(StgWord64) / sizeof(StgWord))
+#define W64S_TO_WDS(n) ((n) * sizeof(StgWord64) / sizeof(StgWord))
// Always safe to use - Return the value at the address
#define ReadSpW(n) (*((StgWord*) SafeSpWP(n)))
-#define ReadSpW64(n) (*((StgWord64*) SafeSpWP(WDS_TO_W64(n))))
+#define ReadSpW64(n) (*((StgWord64*) SafeSpWP(W64S_TO_WDS(n))))
// Perhaps confusingly this still reads a full word, merely the offset is in bytes.
#define ReadSpB(n) (*((StgWord*) SafeSpBP(n)))
@@ -249,9 +249,9 @@ See ticket #25750
#define SafeSpWP(n) \
((StgWord*) ((WITHIN_CAP_CHUNK_BOUNDS_W(n)) ? Sp_plusW(n) : slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n)))
#define SafeSpBP(off_w) \
- ( (StgWord*) (WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \
+ ( (StgWord*) ((WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \
Sp_plusB(off_w) : \
- (StgWord*) ((ptrdiff_t)((off_w) % sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord))))
+ (StgWord*) ((ptrdiff_t)((off_w) % sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord)))))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69ac44b9961e33059b8932b9775c24d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69ac44b9961e33059b8932b9775c24d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] template-haskell: Remove `addrToByteArrayName` and `addrToByteArray`
by Marge Bot (＠marge-bot) 17 Apr '25
by Marge Bot (＠marge-bot) 17 Apr '25
17 Apr '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
386f1854 by Teo Camarasu at 2025-04-17T04:31:55-04:00
template-haskell: Remove `addrToByteArrayName` and `addrToByteArray`
These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage.
Resolves #24782
- - - - -
3 changed files:
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- testsuite/tests/interface-stability/template-haskell-exports.stdout
Changes:
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -1,6 +1,6 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE Safe #-}
{-# LANGUAGE UnboxedTuples #-}
module Language.Haskell.TH.Syntax (
@@ -190,16 +190,11 @@ module Language.Haskell.TH.Syntax (
nothingName,
rightName,
trueName,
- addrToByteArrayName,
- addrToByteArray,
)
where
-import Data.Array.Byte
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
-import GHC.Exts
-import GHC.ST
import System.FilePath
-- This module completely re-exports 'GHC.Boot.TH.Syntax',
@@ -211,17 +206,3 @@ makeRelativeToProject fp | isRelative fp = do
root <- getPackageRoot
return (root </> fp)
makeRelativeToProject fp = return fp
-
--- The following two defintions are copied from 'Data.Byte.Array'
--- in order to preserve the old export list of 'TH.Syntax'.
--- They will soon be removed as part of #24782.
-
-addrToByteArrayName :: Name
-addrToByteArrayName = 'addrToByteArray
-
-addrToByteArray :: Int -> Addr# -> ByteArray
-addrToByteArray (I# len) addr = runST $ ST $
- \s -> case newByteArray# len s of
- (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of
- s'' -> case unsafeFreezeByteArray# mb s'' of
- (# s''', ret #) -> (# s''', ByteArray ret #)
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -13,6 +13,8 @@
* Remove the `Language.Haskell.TH.Lib.Internal` module. This module has long been deprecated, and exposes compiler internals.
Users should use `Language.Haskell.TH.Lib` instead, which exposes a stable version of this API.
+
+ * Remove `addrToByteArrayName` and `addrToByteArray` from `Language.Haskell.TH.Syntax`. These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage.
## 2.23.0.0
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -1369,7 +1369,7 @@ module Language.Haskell.TH.Quote where
quoteFile :: QuasiQuoter -> QuasiQuoter
module Language.Haskell.TH.Syntax where
- -- Safety: Trustworthy
+ -- Safety: Safe
type AnnLookup :: *
data AnnLookup = AnnLookupModule Module | AnnLookupName Name
type AnnTarget :: *
@@ -1780,8 +1780,6 @@ module Language.Haskell.TH.Syntax where
addModFinalizer :: Q () -> Q ()
addTempFile :: GHC.Internal.Base.String -> Q GHC.Internal.IO.FilePath
addTopDecls :: [Dec] -> Q ()
- addrToByteArray :: GHC.Internal.Types.Int -> GHC.Internal.Prim.Addr# -> Data.Array.Byte.ByteArray
- addrToByteArrayName :: Name
badIO :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a
bindCode :: forall (m :: * -> *) a (r :: GHC.Internal.Types.RuntimeRep) (b :: TYPE r). GHC.Internal.Base.Monad m => m a -> (a -> Code m b) -> Code m b
bindCode_ :: forall (m :: * -> *) a (r :: GHC.Internal.Types.RuntimeRep) (b :: TYPE r). GHC.Internal.Base.Monad m => m a -> Code m b -> Code m b
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/386f18548e3c66d04f648a9d34f167a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/386f18548e3c66d04f648a9d34f167a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Refactor Handling of Multiple Default Declarations
by Marge Bot (＠marge-bot) 17 Apr '25
by Marge Bot (＠marge-bot) 17 Apr '25
17 Apr '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e0f3ff11 by Patrick at 2025-04-17T04:31:12-04:00
Refactor Handling of Multiple Default Declarations
Fixes: #25912, #25914, #25934
Previously, GHC discarded all loaded defaults (tcg_default) when local
defaults were encountered during typechecking. According to the
exportable-named-default proposal (sections 2.4.2 and 2.4.3), local
defaults should be merged into tcg_default, retaining any defaults
already present while overriding where necessary.
Key Changes:
* Introduce DefaultProvenance to track the origin of default declarations
(local, imported, or built-in), replacing the original cd_module
in ClassDefaults with cd_provenance :: DefaultProvenance.
* Rename tcDefaults to tcDefaultDecls, limiting its responsibility to only
converting renamed class defaults into ClassDefaults.
* Add extendDefaultEnvWithLocalDefaults to merge local defaults into the
environment, with proper duplication checks:
- Duplicate local defaults for a class trigger an error.
- Local defaults override imported or built-in defaults.
* Update and add related notes: Note [Builtin class defaults],
Note [DefaultProvenance].
* Add regression tests: T25912, T25914, T25934.
Thanks sam and simon for the help on this patch.
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
17 changed files:
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Default.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Types/DefaultEnv.hs
- + testsuite/tests/default/T25912.hs
- + testsuite/tests/default/T25912.stdout
- + testsuite/tests/default/T25912_helper.hs
- + testsuite/tests/default/T25914.hs
- + testsuite/tests/default/T25934.hs
- testsuite/tests/default/all.T
- testsuite/tests/default/default-fail03.stderr
- testsuite/tests/linters/notes.stdout
- testsuite/tests/module/mod58.stderr
Changes:
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -118,7 +118,7 @@ import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
-import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv )
+import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv, DefaultProvenance(..) )
import GHC.Types.Id
import GHC.Types.Id.Make
import GHC.Types.Id.Info
@@ -1333,7 +1333,7 @@ tcIfaceDefault this_mod IfaceDefault { ifDefaultCls = cls_name
; let warn = fmap fromIfaceWarningTxt iface_warn
; return ClassDefaults { cd_class = cls
, cd_types = tys'
- , cd_module = Just this_mod
+ , cd_provenance = DP_Imported this_mod
, cd_warn = warn } }
where
tyThingConClass :: TyThing -> Class
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -85,7 +85,7 @@ import GHC.Tc.Types.Rank (Rank(..))
import GHC.Tc.Types.TH
import GHC.Tc.Utils.TcType
-import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_module))
+import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_provenance), DefaultProvenance (..))
import GHC.Types.Error
import GHC.Types.Error.Codes
import GHC.Types.Hint
@@ -582,11 +582,19 @@ instance Diagnostic TcRnMessage where
TcRnMultipleDefaultDeclarations cls dup_things
-> mkSimpleDecorated $
hang (text "Multiple default declarations for class" <+> quotes (ppr cls))
- 2 (vcat (map pp dup_things))
+ 2 (pp dup_things)
where
- pp :: LDefaultDecl GhcRn -> SDoc
- pp (L locn DefaultDecl {})
- = text "here was another default declaration" <+> ppr (locA locn)
+ pp :: ClassDefaults -> SDoc
+ pp (ClassDefaults { cd_provenance = prov })
+ = case prov of
+ DP_Local { defaultDeclLoc = loc, defaultDeclH98 = isH98 }
+ -> let
+ what =
+ if isH98
+ then text "default declaration"
+ else text "named default declaration"
+ in text "conflicting" <+> what <+> text "at:" <+> ppr loc
+ _ -> empty -- doesn't happen, as local defaults override imported and built-in defaults
TcRnBadDefaultType ty deflt_clss
-> mkSimpleDecorated $
hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of")
@@ -7139,7 +7147,7 @@ pprPatersonCondFailure (PCF_TyFam tc) InTyFamEquation _lhs rhs =
--------------------------------------------------------------------------------
defaultTypesAndImport :: ClassDefaults -> SDoc
-defaultTypesAndImport ClassDefaults{cd_types, cd_module = Just cdm} =
+defaultTypesAndImport ClassDefaults{cd_types, cd_provenance = DP_Imported cdm} =
hang (parens $ pprWithCommas ppr cd_types)
2 (text "imported from" <+> ppr cdm)
defaultTypesAndImport ClassDefaults{cd_types} = parens (pprWithCommas ppr cd_types)
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -1504,7 +1504,7 @@ data TcRnMessage where
Text cases: module/mod58
-}
- TcRnMultipleDefaultDeclarations :: Class -> [LDefaultDecl GhcRn] -> TcRnMessage
+ TcRnMultipleDefaultDeclarations :: Class -> ClassDefaults -> TcRnMessage
{-| TcRnWarnClashingDefaultImports is a warning that occurs when a module imports
more than one default declaration for the same class, and they are not all
=====================================
compiler/GHC/Tc/Gen/Default.hs
=====================================
@@ -5,9 +5,10 @@
-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE LambdaCase #-}
-- | Typechecking @default@ declarations
-module GHC.Tc.Gen.Default ( tcDefaults ) where
+module GHC.Tc.Gen.Default ( tcDefaultDecls, extendDefaultEnvWithLocalDefaults ) where
import GHC.Prelude
import GHC.Hs
@@ -16,7 +17,7 @@ import GHC.Builtin.Names
import GHC.Core.Class
import GHC.Core.Predicate ( Pred (..), classifyPredType )
-import GHC.Data.Maybe ( firstJusts )
+import GHC.Data.Maybe ( firstJusts, maybeToList )
import GHC.Tc.Errors.Types
import GHC.Tc.Gen.HsType
@@ -30,20 +31,17 @@ import GHC.Tc.Utils.TcMType ( newWanted )
import GHC.Tc.Utils.TcType
import GHC.Types.Basic ( TypeOrKind(..) )
-import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), defaultEnv )
+import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), lookupDefaultEnv, insertDefaultEnv, DefaultProvenance (..) )
import GHC.Types.SrcLoc
-import GHC.Unit.Types (Module, ghcInternalUnit, moduleUnit)
+import GHC.Unit.Types (ghcInternalUnit, moduleUnit)
-import GHC.Utils.Misc (fstOf3, sndOf3)
import GHC.Utils.Outputable
import qualified GHC.LanguageExtensions as LangExt
-import Data.Function (on)
-import Data.List.NonEmpty ( NonEmpty (..), groupBy )
+import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
-import Data.Maybe (fromMaybe)
import Data.Traversable ( for )
{- Note [Named default declarations]
@@ -86,7 +84,7 @@ The moving parts are as follows:
* The `DefaultEnv` of all defaults in scope in a module is kept in the `tcg_default`
field of `TcGblEnv`.
-* This field is populated by `GHC.Tc.Gen.Default.tcDefaults` which typechecks
+* This field is populated by `GHC.Tc.Gen.Default.tcDefaultDecls` which typechecks
any local or imported `default` declarations.
* Only a single default declaration can be in effect in any single module for
@@ -103,7 +101,7 @@ The moving parts are as follows:
in effect be `default Num (Integer, Double)` as specified by Haskell Language
Report.
- See Note [Default class defaults] in GHC.Tc.Utils.Env
+ See Note [Builtin class defaults] in GHC.Tc.Utils.Env
* Beside the defaults, the `ExtendedDefaultRules` and `OverloadedStrings`
extensions also affect the traditional `default` declarations that don't name
@@ -120,61 +118,54 @@ The moving parts are as follows:
tracked separately from `ImportAvails`, and returned separately from them by
`GHC.Rename.Names.rnImports`.
-* Class defaults are exported explicitly, as the example above shows. A module's
- exported defaults are tracked in `tcg_default_exports`, which are then
- transferred to `mg_defaults`, `md_defaults`, and `mi_defaults_`.
+* Class defaults are exported explicitly.
+ For example,
+ module M( ..., default C, ... )
+ exports the defaults for class C.
+
+ A module's exported defaults are computed by exports_from_avail,
+ tracked in tcg_default_exports, which are then transferred to mg_defaults,
+ md_defaults, and mi_defaults_.
+
+ Only defaults explicitly exported are actually exported.
+ (i.e. No defaults are exported in a module header like:
+ module M where ...)
+
See Note [Default exports] in GHC.Tc.Gen.Export
* Since the class defaults merely help the solver infer the correct types, they
leave no trace in Haskell Core.
-}
--- See Note [Named default declarations]
-tcDefaults :: [LDefaultDecl GhcRn]
- -> TcM DefaultEnv -- Defaulting types to heave
- -- into Tc monad for later use
- -- in Disambig.
-
-tcDefaults []
- = getDeclaredDefaultTys -- No default declaration, so get the
- -- default types from the envt;
- -- i.e. use the current ones
- -- (the caller will put them back there)
- -- It's important not to return defaultDefaultTys here (which
- -- we used to do) because in a TH program, tcDefaults [] is called
- -- repeatedly, once for each group of declarations between top-level
- -- splices. We don't want to carefully set the default types in
- -- one group, only for the next group to ignore them and install
- -- defaultDefaultTys
-
-tcDefaults decls
- = do { tcg_env <- getGblEnv
- ; let
- here = tcg_mod tcg_env
- is_internal_unit = moduleUnit here == ghcInternalUnit
- ; case (is_internal_unit, decls) of
- -- Some internal GHC modules contain @default ()@ to declare that no defaults can take place
- -- in the module.
- -- We shortcut the treatment of such a default declaration with no class nor types: we won't
- -- try to point 'cd_class' to 'Num' since it may not even exist yet.
- { (True, [L _ (DefaultDecl _ Nothing [])])
- -> return $ defaultEnv []
- -- Otherwise we take apart the declaration into the class constructor and its default types.
- ; _ ->
- do { h2010_dflt_clss <- getH2010DefaultClasses
- ; decls' <- mapMaybeM (declarationParts h2010_dflt_clss) decls
- ; let
- -- Find duplicate default declarations
- decl_tag (mb_cls, _, _) =
- case mb_cls of
- Nothing -> Nothing
- Just cls -> if cls `elem` h2010_dflt_clss
- then Nothing
- else Just cls
- decl_groups = groupBy ((==) `on` decl_tag) decls'
- ; decls_without_dups <- mapM (reportDuplicates here h2010_dflt_clss) decl_groups
- ; return $ defaultEnv (concat decls_without_dups)
- } } }
+-- | Typecheck a collection of default declarations. These can be either:
+--
+-- - Haskell 98 default declarations, of the form @default (Float, Double)@
+-- - Named default declarations, of the form @default Cls(Int, Char)@.
+-- See Note [Named default declarations]
+tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
+tcDefaultDecls decls =
+ do
+ tcg_env <- getGblEnv
+ let here = tcg_mod tcg_env
+ is_internal_unit = moduleUnit here == ghcInternalUnit
+ case (is_internal_unit, decls) of
+ -- No default declarations
+ (_, []) -> return []
+ -- As per Remark [default () in ghc-internal] in Note [Builtin class defaults],
+ -- some modules in ghc-internal include an empty `default ()` declaration, in order
+ -- to disable built-in defaults. This is no longer necessary (see `GHC.Tc.Utils.Env.tcGetDefaultTys`),
+ -- but we must still make sure not to error if we fail to look up e.g. the 'Num'
+ -- typeclass when typechecking such a default declaration. To do this, we wrap
+ -- calls of 'tcLookupClass' in 'tryTc'.
+ (True, [L _ (DefaultDecl _ Nothing [])]) -> do
+ h2010_dflt_clss <- foldMapM (fmap maybeToList . fmap fst . tryTc . tcLookupClass) =<< getH2010DefaultNames
+ case NE.nonEmpty h2010_dflt_clss of
+ Nothing -> return []
+ Just h2010_dflt_clss' -> toClassDefaults h2010_dflt_clss' decls
+ -- Otherwise we take apart the declaration into the class constructor and its default types.
+ _ -> do
+ h2010_dflt_clss <- getH2010DefaultClasses
+ toClassDefaults h2010_dflt_clss decls
where
getH2010DefaultClasses :: TcM (NonEmpty Class)
-- All the classes subject to defaulting with a Haskell 2010 default
@@ -186,18 +177,18 @@ tcDefaults decls
-- No extensions: Num
-- OverloadedStrings: add IsString
-- ExtendedDefaults: add Show, Eq, Ord, Foldable, Traversable
- getH2010DefaultClasses
- = do { num_cls <- tcLookupClass numClassName
- ; ovl_str <- xoptM LangExt.OverloadedStrings
+ getH2010DefaultClasses = mapM tcLookupClass =<< getH2010DefaultNames
+ getH2010DefaultNames
+ = do { ovl_str <- xoptM LangExt.OverloadedStrings
; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
- ; deflt_str <- if ovl_str
- then mapM tcLookupClass [isStringClassName]
- else return []
- ; deflt_interactive <- if ext_deflt
- then mapM tcLookupClass interactiveClassNames
- else return []
- ; let extra_clss = deflt_str ++ deflt_interactive
- ; return $ num_cls :| extra_clss
+ ; let deflt_str = if ovl_str
+ then [isStringClassName]
+ else []
+ ; let deflt_interactive = if ext_deflt
+ then interactiveClassNames
+ else []
+ ; let extra_clss_names = deflt_str ++ deflt_interactive
+ ; return $ numClassName :| extra_clss_names
}
declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type]))
declarationParts h2010_dflt_clss decl@(L locn (DefaultDecl _ mb_cls_name dflt_hs_tys))
@@ -220,20 +211,49 @@ tcDefaults decls
; return (Just cls, decl, tau_tys)
} }
- reportDuplicates :: Module -> NonEmpty Class -> NonEmpty (Maybe Class, LDefaultDecl GhcRn, [Type]) -> TcM [ClassDefaults]
- reportDuplicates here h2010_dflt_clss ((mb_cls, _, tys) :| [])
- = pure [ ClassDefaults{cd_class = c, cd_types = tys, cd_module = Just here, cd_warn = Nothing }
- | c <- case mb_cls of
- Nothing -> NE.toList h2010_dflt_clss
- Just cls -> [cls]
- ]
- -- Report an error on multiple default declarations for the same class in the same module.
- -- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module
- reportDuplicates _ (num_cls :| _) decls@((_, L locn _, _) :| _)
- = setSrcSpan (locA locn) (addErrTc $ dupDefaultDeclErr cls (sndOf3 <$> decls))
- >> pure []
+ toClassDefaults :: NonEmpty Class -> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
+ toClassDefaults h2010_dflt_clss dfs = do
+ dfs <- mapMaybeM (declarationParts h2010_dflt_clss) dfs
+ return $ concatMap (go False) dfs
where
- cls = fromMaybe num_cls $ firstJusts (fmap fstOf3 decls)
+ go h98 = \case
+ (Nothing, rn_decl, tys) -> concatMap (go True) [(Just cls, rn_decl, tys) | cls <- NE.toList h2010_dflt_clss]
+ (Just cls, (L locn _), tys) -> [(L locn $ ClassDefaults cls tys (DP_Local (locA locn) h98) Nothing)]
+
+-- | Extend the default environment with the local default declarations
+-- and do the action in the extended environment.
+extendDefaultEnvWithLocalDefaults :: [LocatedA ClassDefaults] -> TcM a -> TcM a
+extendDefaultEnvWithLocalDefaults decls action = do
+ tcg_env <- getGblEnv
+ let default_env = tcg_default tcg_env
+ new_default_env <- insertDefaultDecls default_env decls
+ updGblEnv (\gbl -> gbl { tcg_default = new_default_env } ) $ action
+
+-- | Insert local default declarations into the default environment.
+--
+-- See 'insertDefaultDecl'.
+insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv
+insertDefaultDecls = foldrM insertDefaultDecl
+-- | Insert a local default declaration into the default environment.
+--
+-- If the class already has a local default declaration in the DefaultEnv,
+-- report an error and return the original DefaultEnv. Otherwise, override
+-- any existing default declarations (e.g. imported default declarations).
+--
+-- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module
+insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv
+insertDefaultDecl (L decl_loc new_cls_defaults ) default_env =
+ case lookupDefaultEnv default_env (className cls) of
+ Just cls_defaults
+ | DP_Local {} <- cd_provenance cls_defaults
+ -> do { setSrcSpan (locA decl_loc) (addErrTc $ TcRnMultipleDefaultDeclarations cls cls_defaults)
+ ; return default_env }
+ _ -> return $ insertDefaultEnv new_cls_defaults default_env
+ -- NB: this overrides imported and built-in default declarations
+ -- for this class, if there were any.
+ where
+ cls = cd_class new_cls_defaults
+
-- | Check that the type is an instance of at least one of the default classes.
--
@@ -289,10 +309,6 @@ simplifyDefault cls dflt_ty@(L l _)
-> Nothing
}
-dupDefaultDeclErr :: Class -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
-dupDefaultDeclErr cls (L _ DefaultDecl {} :| dup_things)
- = TcRnMultipleDefaultDeclarations cls dup_things
-
{- Note [Instance check for default declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see a named default declaration, such as:
@@ -327,4 +343,4 @@ whether each type is an instance of:
- ... or the IsString class, with -XOverloadedStrings
- ... or any of the Show, Eq, Ord, Foldable, and Traversable classes,
with -XExtendedDefaultRules
--}
\ No newline at end of file
+-}
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -282,7 +282,7 @@ example,
would import the above `default IsString (Text, String)` declaration into the
importing module.
-The `cd_module` field of `ClassDefaults` tracks the module whence the default was
+The `cd_provenance` field of `ClassDefaults` tracks the module whence the default was
imported from, for the purpose of warning reports. The said warning report may be
triggered by `-Wtype-defaults` or by a user-defined `WARNING` pragma attached to
the default export. In the latter case the warning text is stored in the
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -383,6 +383,7 @@ the actual contents of the module are wired in to GHC.
-}
{- Note [Disambiguation of multiple default declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Note [Named default declarations] in GHC.Tc.Gen.Default
@@ -1811,9 +1812,8 @@ tcTyClsInstDecls tycl_decls deriv_decls default_decls binds
--
-- But only after we've typechecked 'default' declarations.
-- See Note [Typechecking default declarations]
- defaults <- tcDefaults default_decls ;
- updGblEnv (\gbl -> gbl { tcg_default = defaults }) $ do {
-
+ defaults <- tcDefaultDecls default_decls
+ ; extendDefaultEnvWithLocalDefaults defaults $ do {
-- Careful to quit now in case there were instance errors, so that
-- the deriving errors don't pile up as well.
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -128,8 +128,7 @@ import GHC.Types.SourceFile
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
-import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults(..),
- defaultEnv, emptyDefaultEnv, lookupDefaultEnv, unitDefaultEnv )
+import GHC.Types.DefaultEnv
import GHC.Types.Error
import GHC.Types.Id
import GHC.Types.Id.Info ( RecSelParent(..) )
@@ -971,21 +970,28 @@ isBrackStage _other = False
************************************************************************
-}
-{- Note [Default class defaults]
+{- Note [Builtin class defaults]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In absence of user-defined `default` declarations, the set of class defaults in
-effect (i.e. `DefaultEnv`) is determined by the absence or
-presence of the `ExtendedDefaultRules` and `OverloadedStrings` extensions. In their
-absence, the only rule in effect is `default Num (Integer, Double)` as specified by
-Haskell Language Report.
-
-In GHC's internal packages `DefaultEnv` is empty to minimize cross-module dependencies:
-the `Num` class or `Integer` type may not even be available in low-level modules. If
-you don't do this, attempted defaulting in package ghc-prim causes an actual crash
-(attempting to look up the `Integer` type).
-
-A user-defined `default` declaration overrides the defaults for the specified class,
-and only for that class.
+In the absence of user-defined `default` declarations, the set of class defaults in
+effect (i.e. the `DefaultEnv`) depends on whether the `ExtendedDefaultRules` and
+`OverloadedStrings` extensions are enabled. In their absence, the only rule in effect
+is `default Num (Integer, Double)`, as specified by the Haskell 2010 report.
+
+Remark [No built-in defaults in ghc-internal]
+
+ When typechecking the ghc-internal package, we **do not** include any built-in
+ defaults. This is because, in ghc-internal, types such as 'Num' or 'Integer' may
+ not even be available (they haven't been typechecked yet).
+
+Remark [default () in ghc-internal]
+
+ Historically, modules inside ghc-internal have used a single default declaration,
+ of the form `default ()`, to work around the problem described in
+ Remark [No built-in defaults in ghc-internal].
+
+ When we typecheck such a default declaration, we must also make sure not to fail
+ if e.g. 'Num' is not in scope. We thus have special treatment for this case,
+ in 'GHC.Tc.Gen.Default.tcDefaultDecls'.
-}
tcGetDefaultTys :: TcM (DefaultEnv, -- Default classes and types
@@ -997,7 +1003,7 @@ tcGetDefaultTys
-- See also #1974
builtinDefaults cls tys = ClassDefaults{ cd_class = cls
, cd_types = tys
- , cd_module = Nothing
+ , cd_provenance = DP_Builtin
, cd_warn = Nothing }
-- see Note [Named default declarations] in GHC.Tc.Gen.Default
@@ -1005,7 +1011,8 @@ tcGetDefaultTys
; this_module <- tcg_mod <$> getGblEnv
; let this_unit = moduleUnit this_module
; if this_unit == ghcInternalUnit
- -- see Note [Default class defaults]
+ -- see Remark [No built-in defaults in ghc-internal]
+ -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env
then return (defaults, extended_defaults)
else do
-- not one of the built-in units
@@ -1037,6 +1044,8 @@ tcGetDefaultTys
}
-- The Num class is already user-defaulted, no need to construct the builtin default
_ -> pure emptyDefaultEnv
+ -- Supply the built-in defaults, but make the user-supplied defaults
+ -- override them.
; let deflt_tys = mconcat [ extDef, numDef, ovlStr, defaults ]
; return (deflt_tys, extended_defaults) } }
=====================================
compiler/GHC/Types/DefaultEnv.hs
=====================================
@@ -1,7 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE LambdaCase #-}
module GHC.Types.DefaultEnv
( ClassDefaults (..)
+ , DefaultProvenance (..)
, DefaultEnv
, emptyDefaultEnv
, isEmptyDefaultEnv
@@ -12,6 +14,8 @@ module GHC.Types.DefaultEnv
, defaultList
, plusDefaultEnv
, mkDefaultEnv
+ , insertDefaultEnv
+ , isHaskell2010Default
)
where
@@ -22,6 +26,7 @@ import GHC.Tc.Utils.TcType (Type)
import GHC.Types.Name (Name, nameUnique, stableNameCmp)
import GHC.Types.Name.Env
import GHC.Types.Unique.FM (lookupUFM_Directly)
+import GHC.Types.SrcLoc (SrcSpan)
import GHC.Unit.Module.Warnings (WarningTxt)
import GHC.Unit.Types (Module)
import GHC.Utils.Outputable
@@ -37,13 +42,73 @@ import Data.Function (on)
-- NB: this includes Haskell98 default declarations, at the 'Num' key.
type DefaultEnv = NameEnv ClassDefaults
+{- Note [DefaultProvenance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Each `ClassDefault` is annotated with its `DefaultProvenance`, which
+says where the default came from. Specifically
+* `DP_Local loc h98`: the default came from an explicit `default` declaration in the module
+ being compiled, at location `loc`, and the boolean `h98` indicates whether
+ it was from a Haskell 98 default declaration (e.g. `default (Int, Double)`).
+* `DP_Imported M`: the default was imported, it is explicitly exported by module `M`.
+* `DP_Builtin`: the default was automatically provided by GHC.
+ see Note [Builtin class defaults] in GHC.Tc.Utils.Env
+
+These annotations are used to disambiguate multiple defaults for the same class.
+For example, consider the following modules:
+
+ module M( default C ) where { default C( ... ) }
+ module M2( default C) where { import M }
+ module N( default C () where { default C(... ) }
+
+ module A where { import M2 }
+ module B where { import M2; import N }
+ module A1 where { import N; default C ( ... ) }
+ module B2 where { default C ( ... ); default C ( ... ) }
+
+When compiling N, the default for C is annotated with DP_Local loc.
+When compiling M2, the default for C is annotated with DP_Local M.
+When compiling A, the default for C is annotated with DP_Imported M2.
+
+Cases we needed to disambiguate:
+ * Compiling B, two defaults for C: DP_Imported M2, DP_Imported N.
+ * Compiling A1, two defaults for C: DP_Imported N, DP_Local loc.
+ * Compiling B2, two defaults for C: DP_Local loc1, DP_Local loc2.
+
+For how we disambiguate these cases,
+See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module.
+-}
+
+-- | The provenance of a collection of default types for a class.
+-- see Note [DefaultProvenance] for more details
+data DefaultProvenance
+ -- | A locally defined default declaration.
+ = DP_Local
+ { defaultDeclLoc :: SrcSpan -- ^ The 'SrcSpan' of the default declaration
+ , defaultDeclH98 :: Bool -- ^ Is this a Haskell 98 default declaration?
+ }
+ -- | Built-in class defaults.
+ | DP_Builtin
+ -- | Imported class defaults.
+ | DP_Imported Module -- ^ The module from which the defaults were imported
+ deriving (Eq, Data)
+
+instance Outputable DefaultProvenance where
+ ppr (DP_Local loc h98) = ppr loc <> (if h98 then text " (H98)" else empty)
+ ppr DP_Builtin = text "built-in"
+ ppr (DP_Imported mod) = ppr mod
+
+isHaskell2010Default :: DefaultProvenance -> Bool
+isHaskell2010Default = \case
+ DP_Local { defaultDeclH98 = isH98 } -> isH98
+ DP_Builtin -> True
+ DP_Imported {} -> False
+
-- | Defaulting type assignments for the given class.
data ClassDefaults
= ClassDefaults { cd_class :: Class -- ^ The class whose defaults are being defined
, cd_types :: [Type]
- , cd_module :: Maybe Module
- -- ^ @Nothing@ for built-in,
- -- @Just@ the current module or the module whence the default was imported
+ , cd_provenance :: DefaultProvenance
+ -- ^ Where the defaults came from
-- see Note [Default exports] in GHC.Tc.Gen.Export
, cd_warn :: Maybe (WarningTxt GhcRn)
-- ^ Warning emitted when the default is used
@@ -70,6 +135,9 @@ defaultList :: DefaultEnv -> [ClassDefaults]
defaultList = sortBy (stableNameCmp `on` className . cd_class) . nonDetNameEnvElts
-- sortBy recovers determinism
+insertDefaultEnv :: ClassDefaults -> DefaultEnv -> DefaultEnv
+insertDefaultEnv d env = extendNameEnv env (className $ cd_class d) d
+
lookupDefaultEnv :: DefaultEnv -> Name -> Maybe ClassDefaults
lookupDefaultEnv env = lookupUFM_Directly env . nameUnique
=====================================
testsuite/tests/default/T25912.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE NamedDefaults #-}
+
+module Main where
+
+import T25912_helper
+
+-- now we declare the default instances
+-- for the classes C again to check that
+-- it won't hide the default instances for class B
+default C (String)
+
+main :: IO ()
+main = do
+ print b
=====================================
testsuite/tests/default/T25912.stdout
=====================================
@@ -0,0 +1 @@
+"String"
=====================================
testsuite/tests/default/T25912_helper.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE NamedDefaults #-}
+
+module T25912_helper ( default C, C(c), default B, b ) where
+
+class C a where
+ c :: a
+instance C Int where
+ c = 1
+instance C String where
+ c = "String"
+default C (String)
+
+class B a where
+ b :: a
+instance B String where
+ b = "String"
+default B (String)
=====================================
testsuite/tests/default/T25914.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE NamedDefaults, OverloadedStrings #-}
+module NamedDefaultsNum where
+import Data.String
+default Num ()
+foo = "abc"
=====================================
testsuite/tests/default/T25934.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE ExtendedDefaultRules #-}
+{-# LANGUAGE NamedDefaults #-}
+module T25934 where
+default Num (Int)
+default Show (Int)
=====================================
testsuite/tests/default/all.T
=====================================
@@ -39,3 +39,6 @@ test('T25858v2', [extra_files(['T25858v2_helper.hs'])], multimod_compile_and_run
test('T25858v3', [extra_files(['T25858v3_helper.hs'])], multimod_compile_and_run, ['T25858v3', ''])
test('T25858v4', normal, compile_and_run, [''])
test('T25882', normal, compile, [''])
+test('T25912', [extra_files(['T25912_helper.hs'])], multimod_compile_and_run, ['T25912', ''])
+test('T25914', normal, compile, [''])
+test('T25934', normal, compile, [''])
=====================================
testsuite/tests/default/default-fail03.stderr
=====================================
@@ -1,3 +1,4 @@
-default-fail03.hs:4:1: [GHC-99565]
+default-fail03.hs:4:1: error: [GHC-99565]
Multiple default declarations for class ‘Num’
- here was another default declaration default-fail03.hs:3:1-29
+ conflicting named default declaration at: default-fail03.hs:3:1-29
+
=====================================
testsuite/tests/linters/notes.stdout
=====================================
@@ -8,7 +8,7 @@ ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4345:8: Note [Lambda-boun
ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1387:37: Note [Gentle mode]
ref compiler/GHC/Core/Opt/Specialise.hs:1761:29: Note [Arity decrease]
ref compiler/GHC/Core/TyCo/Rep.hs:1783:31: Note [What prevents a constraint from floating]
-ref compiler/GHC/Driver/DynFlags.hs:1216:52: Note [Eta-reduction in -O0]
+ref compiler/GHC/Driver/DynFlags.hs:1218:52: Note [Eta-reduction in -O0]
ref compiler/GHC/Driver/Main.hs:1901:34: Note [simpleTidyPgm - mkBootModDetailsTc]
ref compiler/GHC/Hs/Expr.hs:189:63: Note [Pending Splices]
ref compiler/GHC/Hs/Expr.hs:2194:87: Note [Lifecycle of a splice]
@@ -18,10 +18,8 @@ ref compiler/GHC/Hs/Pat.hs:151:74: Note [Lifecycle of a splice]
ref compiler/GHC/HsToCore/Pmc/Solver.hs:860:20: Note [COMPLETE sets on data families]
ref compiler/GHC/HsToCore/Quote.hs:1533:7: Note [How brackets and nested splices are handled]
ref compiler/GHC/Stg/Unarise.hs:457:32: Note [Renaming during unarisation]
-ref compiler/GHC/Tc/Gen/Default.hs:87:6: Note [Disambiguation of multiple default declarations]
-ref compiler/GHC/Tc/Gen/Default.hs:193:11: Note [Disambiguation of multiple default declarations]
ref compiler/GHC/Tc/Gen/HsType.hs:563:56: Note [Skolem escape prevention]
-ref compiler/GHC/Tc/Gen/HsType.hs:2693:7: Note [Matching a kind signature with a declaration]
+ref compiler/GHC/Tc/Gen/HsType.hs:2717:7: Note [Matching a kind signature with a declaration]
ref compiler/GHC/Tc/Gen/Pat.hs:284:20: Note [Typing patterns in pattern bindings]
ref compiler/GHC/Tc/Gen/Pat.hs:1378:7: Note [Matching polytyped patterns]
ref compiler/GHC/Tc/Gen/Sig.hs:91:10: Note [Overview of type signatures]
@@ -30,8 +28,6 @@ ref compiler/GHC/Tc/Gen/Splice.hs:543:35: Note [PendingRnSplice]
ref compiler/GHC/Tc/Gen/Splice.hs:670:7: Note [How brackets and nested splices are handled]
ref compiler/GHC/Tc/Gen/Splice.hs:909:11: Note [How brackets and nested splices are handled]
ref compiler/GHC/Tc/Instance/Family.hs:458:35: Note [Constrained family instances]
-ref compiler/GHC/Tc/Module.hs:385:3: Note [Disambiguation of multiple default declarations]
-ref compiler/GHC/Tc/Module.hs:420:7: Note [Disambiguation of multiple default declarations]
ref compiler/GHC/Tc/Solver/Rewrite.hs:1015:7: Note [Stability of rewriting]
ref compiler/GHC/Tc/TyCl.hs:1322:6: Note [Unification variables need fresh Names]
ref compiler/GHC/Tc/Types/Constraint.hs:209:9: Note [NonCanonical Semantics]
=====================================
testsuite/tests/module/mod58.stderr
=====================================
@@ -1,4 +1,4 @@
-
mod58.hs:4:1: error: [GHC-99565]
Multiple default declarations for class ‘Num’
- here was another default declaration mod58.hs:3:1-21
+ conflicting default declaration at: mod58.hs:3:1-21
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0f3ff11719f1ee343d1b5d1fd3193d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0f3ff11719f1ee343d1b5d1fd3193d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0