27 Jun '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-8 at Glasgow Haskell Compiler / GHC
Commits:
2a1ba3e6 by Rodrigo Mesquita at 2025-06-27T15:38:47+01:00
BRK_FUN in rts
- - - - -
1 changed file:
- rts/Interpreter.c
Changes:
=====================================
rts/Interpreter.c
=====================================
@@ -1506,11 +1506,11 @@ run_BCO:
// stop the current thread if either `stop_next_breakpoint` is
// true OR if the ignore count for this particular breakpoint is zero
- StgInt ignore_count = ((StgInt*)breakPoints->payload)[BCO_LIT(arg6_tick_index)];
+ StgInt ignore_count = ((StgInt*)breakPoints->payload)[BCO_LIT(arg4_info_index)];
if (stop_next_breakpoint == false && ignore_count > 0)
{
// decrement and write back ignore count
- ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
+ ((StgInt*)breakPoints->payload)[BCO_LIT(arg4_info_index)] = --ignore_count;
}
else if (stop_next_breakpoint == true || ignore_count == 0)
{
@@ -1544,10 +1544,7 @@ run_BCO:
// Arrange the stack to call the breakpoint IO action, and
// 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
+ // ioAction :: Addr# -- the breakpoint info module
// -> Addr# -- the breakpoint info module unit id
// -> Int# -- the breakpoint info index
// -> Bool -- exception?
@@ -1557,23 +1554,17 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- 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_)arg6_tick_index;
+ Sp_subW(13);
+ SpW(12) = (W_)obj;
+ SpW(11) = (W_)&stg_apply_interp_info;
+ SpW(10) = (W_)new_aps;
+ SpW(9) = (W_)False_closure; // True <=> an exception
+ SpW(8) = (W_)&stg_ap_ppv_info;
+ SpW(7) = (W_)BCO_LIT(arg4_info_index);
SpW(6) = (W_)&stg_ap_n_info;
- SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id);
+ SpW(5) = (W_)BCO_LIT(arg3_info_mod_id);
SpW(4) = (W_)&stg_ap_n_info;
- SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
+ SpW(3) = (W_)BCO_LIT(arg2_info_mod_name);
SpW(2) = (W_)&stg_ap_n_info;
SpW(1) = (W_)ioAction;
SpW(0) = (W_)&stg_enter_info;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a1ba3e64481e43efc1f40cf9001abc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a1ba3e64481e43efc1f40cf9001abc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/step-out-8] 2 commits: compiler: make ModBreaks serializable
by Rodrigo Mesquita (＠alt-romes) 27 Jun '25
by Rodrigo Mesquita (＠alt-romes) 27 Jun '25
27 Jun '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-8 at Glasgow Haskell Compiler / GHC
Commits:
aa8de259 by Cheng Shao at 2025-06-27T10:42:13+01:00
compiler: make ModBreaks serializable
- - - - -
9d5e8eab by Rodrigo Mesquita at 2025-06-27T15:35:39+01:00
Mais...
- - - - -
15 changed files:
- compiler/GHC.hs
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Session/Inspect.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -408,6 +408,8 @@ import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts, orphNamesOfFamInst )
import GHC.Core.InstEnv
import GHC.Core
+import GHC.HsToCore.Breakpoints
+
import GHC.Data.Maybe
import GHC.Types.Id
@@ -427,7 +429,6 @@ import GHC.Types.Basic
import GHC.Types.TyThing
import GHC.Types.Name.Env
import GHC.Types.TypeEnv
-import GHC.Types.Breakpoint
import GHC.Types.PkgQual
import GHC.Unit
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -28,7 +28,6 @@ import GHC.Prelude hiding ( any )
import GHC.ByteCode.Instr
import GHC.ByteCode.InfoTable
import GHC.ByteCode.Types
-import GHCi.RemoteTypes
import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord )
import GHC.Types.Name
@@ -843,12 +842,12 @@ assembleI platform i = case i of
W8 -> emit_ bci_OP_INDEX_ADDR_08 []
_ -> unsupported_width
- BRK_FUN arr (InternalBreakpointId info_mod infox) cc -> do
- p1 <- ptr (BCOPtrBreakArray arr)
+ BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do
+ p1 <- ptr $ BCOPtrBreakArray info_mod
info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod
info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId info_mod
info_wix <- int infox
- np <- addr cc
+ np <- lit1 $ BCONPtrCostCentre ibi
emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr
, Op info_wix, Op np ]
@@ -892,7 +891,6 @@ assembleI platform i = case i of
literal (LitRubbish {}) = word 0
litlabel fs = lit1 (BCONPtrLbl fs)
- addr (RemotePtr a) = word (fromIntegral a)
words ws = lit (fmap BCONPtrWord ws)
word w = words (OnlyOne w)
word2 w1 w2 = words (OnlyTwo w1 w2)
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -10,7 +10,7 @@
-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]
module GHC.ByteCode.Breakpoints
( -- * Internal Mod Breaks
- InternalModBreaks(imodBreaks_breakInfo), CgBreakInfo(..)
+ InternalModBreaks(..), CgBreakInfo(..)
, mkInternalModBreaks
-- ** Operations
@@ -114,12 +114,12 @@ data InternalBreakpointId = InternalBreakpointId
-- 'InternalModBreaks' are constructed during bytecode generation and stored in
-- 'CompiledByteCode' afterwards.
data InternalModBreaks = InternalModBreaks
- { imodBreaks_breakInfo :: IntMap CgBreakInfo
+ { imodBreaks_breakInfo :: !(IntMap CgBreakInfo)
-- ^ Access code-gen time information about a breakpoint, indexed by
-- 'InternalBreakpointId'.
- , imodBreaks_module :: !Module
- -- ^ Cache the module corresponding to these 'InternalModBreaks' for
- -- sanity checks. Don't export it!
+ , imodBreaks_module :: !Module
+ -- ^ Also cache the module corresponding to these 'InternalModBreaks',
+ -- for instance for internal sanity checks.
}
-- | Construct an 'InternalModBreaks'
@@ -161,24 +161,6 @@ assert_modules_match ibi_mod imbs_mod =
(text "Tried to query the InternalModBreaks of module" <+> ppr imbs_mod
<+> text "with an InternalBreakpointId for module" <+> ppr ibi_mod)
--- TODO: See what Cheng has in .
--- mkCCSArray
--- :: Interp -> Module -> Int -> [Tick]
--- -> IO (Array BreakTickIndex (RemotePtr GHC.Stack.CCS.CostCentre))
--- mkCCSArray interp modul count entries
--- | interpreterProfiled interp = do
--- let module_str = moduleNameString (moduleName modul)
--- costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)
--- return (listArray (0,count-1) costcentres)
--- | otherwise = return (listArray (0,-1) [])
--- where
--- mk_one t = (name, src)
--- where name = concat $ intersperse "." $ tick_path t
--- src = renderWithContext defaultSDocContext $ ppr $ tick_loc t
--- , modBreaks_ccs :: !(Array BreakTickIndex (RemotePtr CostCentre))
--- -- ^ Array pointing to cost centre for each breakpoint
--- ccs <- mkCCSArray interpProfiled mod count entries
-
--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -15,7 +15,6 @@ import GHC.Prelude
import GHC.ByteCode.Types
import GHC.Cmm.Type (Width)
-import GHCi.RemoteTypes
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Utils.Outputable
import GHC.Types.Name
@@ -32,10 +31,8 @@ import Data.Word
import Data.ByteString (ByteString)
#endif
-import GHC.Stack.CCS (CostCentre)
import GHC.Stg.Syntax
-import GHCi.BreakArray (BreakArray)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -261,9 +258,7 @@ data BCInstr
-- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode
-- Breakpoints
- | BRK_FUN (ForeignRef BreakArray)
- !InternalBreakpointId
- (RemotePtr CostCentre)
+ | BRK_FUN !InternalBreakpointId
-- An internal breakpoint for triggering a break on any case alternative
-- See Note [Debugger: BRK_ALTS]
@@ -459,7 +454,7 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN _ (InternalBreakpointId info_mod infox) _)
+ ppr (BRK_FUN (InternalBreakpointId info_mod infox))
= text "BRK_FUN" <+> text "<breakarray>"
<+> ppr info_mod <+> ppr infox
<+> text "<cc>"
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -28,9 +28,11 @@ import GHCi.ResolvedBCO
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids
+import GHC.Unit.Module.Env
import GHC.Unit.Types
import GHC.Data.FastString
+import GHC.Data.Maybe
import GHC.Data.SizedSeq
import GHC.Linker.Types
@@ -47,6 +49,7 @@ import GHC.Types.Unique.DFM
import Data.Array.Unboxed
import Foreign.Ptr
import GHC.Exts
+import GHC.HsToCore.Breakpoints (BreakpointId(..))
{-
Linking interpretables into something we can run
@@ -95,6 +98,14 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of
BCONPtrFFIInfo (FFIInfo {..}) -> do
RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet
pure $ fromIntegral p
+ BCONPtrCostCentre ibi
+ | interpreterProfiled interp -> do
+ (BreakpointId tick_mod tick_no) <- (error "todo") ibi
+ case expectJust (lookupModuleEnv (ccs_env le) tick_mod) ! tick_no of
+ RemotePtr p -> pure $ fromIntegral p
+ | otherwise ->
+ case toRemotePtr nullPtr of
+ RemotePtr p -> pure $ fromIntegral p
lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
lookupStaticPtr interp addr_of_label_string = do
@@ -175,8 +186,9 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
BCOPtrBCO bco
-> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco
- BCOPtrBreakArray breakarray
- -> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba)
+ BCOPtrBreakArray tick_mod ->
+ withForeignRef (expectJust (lookupModuleEnv (breakarray_env le) tick_mod)) $
+ \ba -> pure $ ResolvedBCOPtrBreakArray ba
-- | Look up the address of a Haskell symbol in the currently
-- loaded units.
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -36,7 +36,6 @@ import GHC.Types.Name.Env
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
import GHC.Types.SptEntry
-import GHCi.BreakArray
import GHCi.Message
import GHCi.RemoteTypes
import GHCi.FFI
@@ -48,6 +47,7 @@ import Data.ByteString (ByteString)
import qualified GHC.Exts.Heap as Heap
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
import GHC.HsToCore.Breakpoints (ModBreaks)
+import GHC.Unit.Module
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -63,11 +63,20 @@ data CompiledByteCode = CompiledByteCode
-- ^ top-level strings (heap allocated)
, bc_breaks :: (Maybe (InternalModBreaks, ModBreaks))
- -- ^ internal breakpoint info (no tick-level 'ModBreaks' if breakpoints are disabled)
+ -- ^ All (internal and tick-level) breakpoint information (no information
+ -- if breakpoints are disabled).
--
+ -- This information is used when loading a bytecode object: we will
+ -- construct the arrays to be used at runtime to trigger breakpoints then
+ -- from it (in 'allocateBreakArrays' and 'allocateCCS' in 'GHC.ByteCode.Loader').
+ --
+ -- Moreover, when a breakpoint is hit we will find the associated
+ -- breakpoint information indexed by the internal breakpoint id here (in
+ -- 'getModBreaks').
+
-- TODO: If ModBreaks is serialized and reconstructed as part of ModDetails
- -- we don't need to keep it here as it can be fetched from the
- -- 'HomeModInfo' directly.
+ -- we don't need to keep it in bc_breaks as it can be fetched from the
+ -- 'HomeModInfo' directly, right?
, bc_spt_entries :: ![SptEntry]
-- ^ Static pointer table entries which should be loaded along with the
@@ -258,8 +267,8 @@ data BCOPtr
= BCOPtrName !Name
| BCOPtrPrimOp !PrimOp
| BCOPtrBCO !UnlinkedBCO
- | BCOPtrBreakArray (ForeignRef BreakArray)
- -- ^ a pointer to a breakpoint's module's BreakArray in GHCi's memory
+ | BCOPtrBreakArray !Module
+ -- ^ Converted to the actual 'BreakArray' remote pointer at link-time
instance NFData BCOPtr where
rnf (BCOPtrBCO bco) = rnf bco
@@ -279,6 +288,8 @@ data BCONPtr
| BCONPtrFS !FastString
-- | A libffi ffi_cif function prototype.
| BCONPtrFFIInfo !FFIInfo
+ -- | A 'CostCentre' remote pointer array's respective 'BreakpointId'
+ | BCONPtrCostCentre !InternalBreakpointId
instance NFData BCONPtr where
rnf x = x `seq` ()
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -304,6 +304,7 @@ import GHC.Cmm.Config (CmmConfig)
import Data.Bifunctor
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable
+import GHC.HsToCore.Breakpoints (ModBreaks)
{- **********************************************************************
%* *
=====================================
compiler/GHC/Driver/Session/Inspect.hs
=====================================
@@ -17,6 +17,7 @@ import GHC.Driver.Session
import GHC.Rename.Names
import GHC.Runtime.Context
import GHC.Runtime.Interpreter
+import GHC.HsToCore.Breakpoints (ModBreaks)
import GHC.Types.Avail
import GHC.Types.Name
import GHC.Types.Name.Ppr
@@ -91,7 +92,7 @@ data ModuleInfo = ModuleInfo {
minf_instances :: [ClsInst],
minf_iface :: Maybe ModIface,
minf_safe :: SafeHaskellMode,
- minf_modBreaks :: Maybe ModBreaks
+ minf_modBreaks :: Maybe (InternalModBreaks, ModBreaks)
}
-- We don't want HomeModInfo here, because a ModuleInfo applies
-- to package modules too.
@@ -196,6 +197,6 @@ modInfoIface = minf_iface
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe = minf_safe
-modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks
+modInfoModBreaks :: ModuleInfo -> Maybe (InternalModBreaks, ModBreaks)
modInfoModBreaks = minf_modBreaks
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -98,6 +98,7 @@ import GHC.Unit.Module.Deps
import Data.List (partition)
import Data.IORef
import GHC.Iface.Make (mkRecompUsageInfo)
+import GHC.Runtime.Interpreter (interpreterProfiled)
{-
************************************************************************
@@ -164,7 +165,7 @@ deSugar hsc_env
; let modBreaks
| Just (_, specs) <- m_tickInfo
, breakpointsAllowed dflags
- = Just $ mkModBreaks mod specs
+ = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs
| otherwise
= Nothing
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE RecordWildCards #-}
+
-- | Information attached to Breakpoints generated from Ticks
--
-- The breakpoint information stored in 'ModBreaks' is generated during
@@ -13,10 +15,11 @@
-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]
module GHC.HsToCore.Breakpoints
( -- * ModBreaks
- mkModBreaks, ModBreaks(modBreaks_locs, modBreaks_vars, modBreaks_decls)
+ mkModBreaks, ModBreaks(..)
-- ** Queries
- , getBreakLoc, getBreakVars, getBreakDecls
+ -- TODO: See where we could use these rather than using the arrays directly.
+ , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS
-- ** Re-exports BreakpointId
, BreakpointId(..), BreakTickIndex
@@ -33,6 +36,7 @@ import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..))
import GHC.Unit.Module (Module)
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import Data.List (intersperse)
--------------------------------------------------------------------------------
-- ModBreaks
@@ -51,16 +55,19 @@ import GHC.Utils.Panic
-- and 'modBreaks_decls'.
data ModBreaks
= ModBreaks
- { modBreaks_locs :: !(Array BreakTickIndex SrcSpan)
+ { modBreaks_locs :: !(Array BreakTickIndex SrcSpan)
-- ^ An array giving the source span of each breakpoint.
- , modBreaks_vars :: !(Array BreakTickIndex [OccName])
+ , modBreaks_vars :: !(Array BreakTickIndex [OccName])
-- ^ An array giving the names of the free variables at each breakpoint.
- , modBreaks_decls :: !(Array BreakTickIndex [String])
+ , modBreaks_decls :: !(Array BreakTickIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
-- See Note [Field modBreaks_decls]
+ , modBreaks_ccs :: !(Array BreakTickIndex (String, String))
+ -- ^ Array pointing to cost centre info for each breakpoint;
+ -- actual 'CostCentre' allocation is done at link-time.
, modBreaks_module :: !Module
-- ^ The module to which this ModBreaks is associated.
- -- We cache this here for internal sanity checks (don't export it!).
+ -- We also cache this here for internal sanity checks.
}
-- | Initialize memory for breakpoint data that is shared between the bytecode
@@ -70,34 +77,52 @@ data ModBreaks
-- generator needs to encode this information for each expression, the data is
-- allocated remotely in GHCi's address space and passed to the codegen as
-- foreign pointers.
-mkModBreaks :: Module -> SizedSeq Tick -> ModBreaks
-mkModBreaks modl extendedMixEntries
+mkModBreaks :: Bool {-^ Whether the interpreter is profiled and thus if we should include store a CCS array -}
+ -> Module -> SizedSeq Tick -> ModBreaks
+mkModBreaks interpreterProfiled modl extendedMixEntries
= let count = fromIntegral $ sizeSS extendedMixEntries
entries = ssElts extendedMixEntries
locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
+ ccs
+ | interpreterProfiled =
+ listArray
+ (0, count - 1)
+ [ ( concat $ intersperse "." $ tick_path t,
+ renderWithContext defaultSDocContext $ ppr $ tick_loc t
+ )
+ | t <- entries
+ ]
+ | otherwise = listArray (0, -1) []
in ModBreaks
{ modBreaks_locs = locsTicks
, modBreaks_vars = varsTicks
, modBreaks_decls = declsTicks
+ , modBreaks_ccs = ccs
, modBreaks_module = modl
}
-- | Get the source span for this breakpoint
getBreakLoc :: BreakpointId -> ModBreaks -> SrcSpan
-getBreakLoc (BreakpointId bid_mod ix) mbs =
- assert_modules_match bid_mod (modBreaks_module mbs) $ modBreaks_locs mbs ! ix
+getBreakLoc = getBreakXXX modBreaks_locs
-- | Get the vars for this breakpoint
getBreakVars :: BreakpointId -> ModBreaks -> [OccName]
-getBreakVars (BreakpointId bid_mod ix) mbs =
- assert_modules_match bid_mod (modBreaks_module mbs) $ modBreaks_vars mbs ! ix
+getBreakVars = getBreakXXX modBreaks_vars
-- | Get the decls for this breakpoint
getBreakDecls :: BreakpointId -> ModBreaks -> [String]
-getBreakDecls (BreakpointId bid_mod ix) mbs =
- assert_modules_match bid_mod (modBreaks_module mbs) $ modBreaks_decls mbs ! ix
+getBreakDecls = getBreakXXX modBreaks_decls
+
+-- | Get the decls for this breakpoint
+getBreakCCS :: BreakpointId -> ModBreaks -> (String, String)
+getBreakCCS = getBreakXXX modBreaks_ccs
+
+-- | Internal utility to access a ModBreaks field at a particular breakpoint index
+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> BreakpointId -> ModBreaks -> a
+getBreakXXX view (BreakpointId bid_mod ix) mbs =
+ assert_modules_match bid_mod (modBreaks_module mbs) $ view mbs ! ix
-- | Assert that the module in the 'BreakpointId' and in 'ModBreaks' match.
assert_modules_match :: Module -> Module -> a -> a
@@ -114,4 +139,3 @@ The breakpoint is in the function called "baz" that is declared in a `let`
or `where` clause of a declaration called "bar", which itself is declared
in a `let` or `where` clause of the top-level function called "foo".
-}
-
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -52,6 +52,7 @@ import GHC.Driver.Config.Finder
import GHC.Tc.Utils.Monad
import GHC.Runtime.Interpreter
+import GHCi.BreakArray
import GHCi.RemoteTypes
import GHC.Iface.Load
import GHCi.Message (ConInfoTable(..), LoadedDLL)
@@ -60,6 +61,7 @@ import GHC.ByteCode.Linker
import GHC.ByteCode.Asm
import GHC.ByteCode.Types
+import GHC.Stack.CCS
import GHC.SysTools
import GHC.Types.Basic
@@ -95,6 +97,7 @@ import GHC.Linker.Types
-- Standard libraries
import Control.Monad
+import Data.Array
import Data.ByteString (ByteString)
import qualified Data.Set as Set
import Data.Char (isSpace)
@@ -119,6 +122,11 @@ import System.Win32.Info (getSystemDirectory)
import GHC.Utils.Exception
import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey)
import GHC.Driver.Downsweep
+import GHC.HsToCore.Breakpoints
+import qualified Data.IntMap.Strict as IM
+import qualified GHC.Runtime.Interpreter as GHCi
+import GHC.Data.Maybe (expectJust)
+import Foreign.Ptr (nullPtr)
@@ -174,6 +182,8 @@ emptyLoaderState = LoaderState
{ closure_env = emptyNameEnv
, itbl_env = emptyNameEnv
, addr_env = emptyNameEnv
+ , breakarray_env = emptyModuleEnv
+ , ccs_env = emptyModuleEnv
}
, pkgs_loaded = init_pkgs
, bcos_loaded = emptyModuleEnv
@@ -691,8 +701,20 @@ loadDecls interp hsc_env span linkable = do
let le = linker_env pls
le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs)
le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs
+ le2_breakarray_env <-
+ allocateBreakArrays
+ interp
+ (breakarray_env le)
+ (catMaybes $ map bc_breaks cbcs)
+ le2_ccs_env <-
+ allocateCCS
+ interp
+ (ccs_env le)
+ (catMaybes $ map bc_breaks cbcs)
let le2 = le { itbl_env = le2_itbl_env
- , addr_env = le2_addr_env }
+ , addr_env = le2_addr_env
+ , breakarray_env = le2_breakarray_env
+ , ccs_env = le2_ccs_env }
-- Link the necessary packages and linkables
new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
@@ -916,7 +938,9 @@ dynLinkBCOs interp pls bcos = do
le1 = linker_env pls
ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs)
ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs
- let le2 = le1 { itbl_env = ie2, addr_env = ae2 }
+ be2 <- allocateBreakArrays interp (breakarray_env le1) (catMaybes $ map bc_breaks cbcs)
+ ce2 <- allocateCCS interp (ccs_env le1) (catMaybes $ map bc_breaks cbcs)
+ let le2 = le1 { itbl_env = ie2, addr_env = ae2, breakarray_env = be2, ccs_env = ce2 }
names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
@@ -1632,3 +1656,71 @@ allocateTopStrings interp topStrings prev_env = do
evaluate $ extendNameEnvList prev_env (zipWith mk_entry bndrs ptrs)
where
mk_entry nm ptr = (nm, (nm, AddrPtr ptr))
+
+-- | Given a list of 'InternalModBreaks and 'ModBreaks' collected from a list of
+-- 'CompiledByteCode', allocate the 'BreakArray' used to trigger breakpoints.
+allocateBreakArrays ::
+ Interp ->
+ ModuleEnv (ForeignRef BreakArray) ->
+ [(InternalModBreaks, ModBreaks)] ->
+ IO (ModuleEnv (ForeignRef BreakArray))
+allocateBreakArrays interp =
+ foldlM
+ ( \be0 (imbs, _mbs) -> do
+ let bi = imodBreaks_breakInfo imbs
+ (hi, _) = IM.findMax bi -- allocate as many slots as internal breakpoints
+ breakArray <- GHCi.newBreakArray interp hi
+ evaluate $ extendModuleEnv be0 (imodBreaks_module imbs) breakArray
+ )
+
+-- | Given a list of 'InternalModBreaks' and 'ModBreaks' collected from a list
+-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is
+-- enabled.
+--
+-- Note that the resulting CostCenter is indexed by the 'InternalBreakpointId',
+-- not by 'BreakpointId'. At runtime, BRK_FUN instructions are annotated with
+-- internal ids -- we'll look them up in the array and push the corresponding
+-- cost center.
+allocateCCS ::
+ Interp ->
+ ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) ->
+ [(InternalModBreaks, ModBreaks)] ->
+ IO (ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
+allocateCCS interp ce mbss
+ | interpreterProfiled interp = do
+ -- First construct the CCSs for each module, using the 'ModBreaks'
+ ccs_map <- foldlM
+ ( \(ccs_map :: ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre))) (_, mbs) -> do
+ ccs <-
+ mkCostCentres
+ interp
+ (moduleNameString $ moduleName $ modBreaks_module mbs)
+ (elems $ modBreaks_ccs mbs)
+ evaluate $
+ extendModuleEnv ccs_map (modBreaks_module mbs) $
+ listArray (0, length ccs - 1) ccs
+ ) emptyModuleEnv mbss
+ -- Now, construct an array indexed by an 'InternalBreakpointId' index by first
+ -- finding the matching 'BreakpointId' and then looking it up in the ccs_map
+ foldlM
+ ( \ce0 (imbs, _) -> do
+ let breakModl = imodBreaks_module imbs
+ breakInfoMap = imodBreaks_breakInfo imbs
+ (hi, _) = IM.findMax breakInfoMap -- as many slots as internal breaks
+ ccss = expectJust $ lookupModuleEnv ccs_map breakModl
+ ccs_im <- foldlM
+ (\(bids :: IM.IntMap (RemotePtr CostCentre)) cgi -> do
+ let tickBreakId = bi_tick_index $ cgb_tick_id cgi
+ pure $ IM.insert tickBreakId (ccss ! tickBreakId) bids
+ ) mempty breakInfoMap
+ evaluate $
+ extendModuleEnv ce0 breakModl $
+ listArray (0, hi-1) $
+ map (\i -> case IM.lookup i ccs_im of
+ Nothing -> toRemotePtr nullPtr
+ Just ccs -> ccs
+ ) [0..hi-1]
+ )
+ ce
+ mbss
+ | otherwise = pure ce
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -50,10 +50,12 @@ where
import GHC.Prelude
import GHC.Unit ( UnitId, Module )
-import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode )
-import GHCi.RemoteTypes ( ForeignHValue, RemotePtr )
+import GHC.ByteCode.Types
+import GHCi.BreakArray
+import GHCi.RemoteTypes
import GHCi.Message ( LoadedDLL )
+import GHC.Stack.CCS
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )
import GHC.Types.Name ( Name )
import GHC.Types.SptEntry
@@ -61,6 +63,7 @@ import GHC.Types.SptEntry
import GHC.Utils.Outputable
import Control.Concurrent.MVar
+import Data.Array
import Data.Time ( UTCTime )
import GHC.Unit.Module.Env
import GHC.Types.Unique.DSet
@@ -69,6 +72,7 @@ import GHC.Unit.Module.WholeCoreBindings
import Data.Maybe (mapMaybe)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as NE
+import GHC.HsToCore.Breakpoints (BreakTickIndex)
{- **********************************************************************
@@ -181,10 +185,17 @@ data LinkerEnv = LinkerEnv
, addr_env :: !AddrEnv
-- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals,
-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.
+
+ , breakarray_env :: !(ModuleEnv (ForeignRef BreakArray))
+ -- ^ Each 'Module's remote pointer of 'BreakArray'.
+
+ , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
+ -- ^ Each 'Module's array of remote pointers of 'CostCentre'.
+ -- Untouched when not profiling.
}
filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv
-filterLinkerEnv f le = LinkerEnv
+filterLinkerEnv f le = le
{ closure_env = filterNameEnv (f . fst) (closure_env le)
, itbl_env = filterNameEnv (f . fst) (itbl_env le)
, addr_env = filterNameEnv (f . fst) (addr_env le)
=====================================
compiler/GHC/Runtime/Debugger/Breakpoints.hs
=====================================
@@ -16,7 +16,7 @@ import Data.Maybe
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as S
-import GHC.ByteCode.Types
+import GHC.HsToCore.Breakpoints
import GHC.Driver.Env
import GHC.Driver.Monad
import GHC.Driver.Session.Inspect
@@ -196,7 +196,7 @@ type TickArray = Array Int [(BreakTickIndex,RealSrcSpan)]
makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray)
makeModuleLineMap m = do
mi <- getModuleInfo m
- return $ mkTickArray . assocs . modBreaks_locs <$> (modInfoModBreaks =<< mi)
+ return $ mkTickArray . assocs . modBreaks_locs <$> (fmap snd . modInfoModBreaks =<< mi)
where
mkTickArray :: [(BreakTickIndex, SrcSpan)] -> TickArray
mkTickArray ticks
@@ -210,7 +210,7 @@ makeModuleLineMap m = do
getModBreak :: GhcMonad m => Module -> m (Maybe ModBreaks)
getModBreak m = do
mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m
- pure $ modInfoModBreaks mod_info
+ pure $ snd <$> modInfoModBreaks mod_info
--------------------------------------------------------------------------------
-- Getting current breakpoint information
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -64,6 +64,7 @@ import GHCi.RemoteTypes
import GHC.ByteCode.Types
import GHC.Linker.Loader as Loader
+import GHC.Linker.Types (LinkerEnv(..))
import GHC.Hs
@@ -111,7 +112,6 @@ import GHC.Types.Unique
import GHC.Types.Unique.Supply
import GHC.Types.Unique.DSet
import GHC.Types.TyThing
-import GHC.Types.Breakpoint
import GHC.Types.Unique.Map
import GHC.Types.Avail
@@ -127,6 +127,8 @@ import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Utils.Monad
import GHC.IfaceToCore
+import GHC.HsToCore.Breakpoints
+import GHC.ByteCode.Breakpoints
import Control.Monad
import Data.Array
@@ -137,6 +139,7 @@ import Data.List (find,intercalate)
import Data.List.NonEmpty (NonEmpty)
import Unsafe.Coerce ( unsafeCoerce )
import qualified GHC.Unit.Home.Graph as HUG
+import GHCi.BreakArray (BreakArray)
-- -----------------------------------------------------------------------------
-- running a statement interactively
@@ -153,7 +156,7 @@ getHistoryModule = bi_tick_mod . historyBreakpointId
getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan
getHistorySpan hug hist = do
let bid = historyBreakpointId hist
- brks <- readModBreaks hug (bi_tick_mod bid)
+ (_, brks) <- readModBreaks hug (bi_tick_mod bid)
return $ modBreaks_locs brks ! bi_tick_index bid
{- | Finds the enclosing top level function name -}
@@ -162,7 +165,7 @@ getHistorySpan hug hist = do
-- for each tick.
findEnclosingDecls :: HUG.HomeUnitGraph -> BreakpointId -> IO [String]
findEnclosingDecls hug bid = do
- brks <- readModBreaks hug (bi_tick_mod bid)
+ (_, brks) <- readModBreaks hug (bi_tick_mod bid)
return $ modBreaks_decls brks ! bi_tick_index bid
-- | Update fixity environment in the current interactive context.
@@ -349,15 +352,17 @@ handleRunStatus step expr bindings final_ids status history0 = do
-- - or one of the stepping options in @EvalOpts@ caused us to stop at one
EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
let hug = hsc_HUG hsc_env
- let ibi = evalBreakpointToId eval_break
- bid <- liftIO $ internalBreakIdToBreakId hug ibi
- tick_brks <- liftIO $ readModBreaks hug (bi_tick_mod bid)
+ let ibi@InternalBreakpointId{ibi_info_index}
+ = evalBreakpointToId eval_break
+ bid <- liftIO $ internalBreakIdToBreakId hug ibi
+ (_, tick_brks) <- liftIO $ readModBreaks hug (bi_tick_mod bid)
+ breakArray <- getBreakArray interp ibi
let
span = modBreaks_locs tick_brks ! bi_tick_index bid
decl = intercalate "." $ modBreaks_decls tick_brks ! bi_tick_index bid
-- Was this breakpoint explicitly enabled (ie. in @BreakArray@)?
- bactive <- liftIO $ breakpointStatus interp (modBreaks_flags tick_brks) (bi_tick_index bid)
+ bactive <- liftIO $ breakpointStatus interp breakArray ibi_info_index
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
@@ -445,8 +450,8 @@ resumeExec step mbCnt
-- When the user specified a break ignore count, set it
-- in the interpreter
case (mb_brkpt, mbCnt) of
- (Just (bid, _ibi), Just cnt) ->
- setupBreakpoint hsc_env bid cnt
+ (Just (bid, ibi), Just cnt) ->
+ setupBreakpoint interp ibi cnt
_ -> return ()
let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
@@ -462,14 +467,16 @@ resumeExec step mbCnt
| otherwise -> pure prevHistoryLst
handleRunStatus step expr bindings final_ids status =<< hist'
-setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157
-setupBreakpoint hsc_env bi cnt = do
- let modl = bi_tick_mod bi
- modBreaks <- liftIO $ readModBreaks (hsc_HUG hsc_env) modl
- let breakarray = modBreaks_flags modBreaks
- interp = hscInterp hsc_env
- _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt
- pure ()
+setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157
+setupBreakpoint interp ibi cnt = do
+ breakArray <- getBreakArray interp ibi
+ liftIO $ GHCi.storeBreakpoint interp breakArray (ibi_info_index ibi) cnt
+
+getBreakArray :: GhcMonad m => Interp -> InternalBreakpointId -> m (ForeignRef BreakArray)
+getBreakArray interp InternalBreakpointId{ibi_info_mod} = do
+ breakArrays <- liftIO $ breakarray_env . linker_env . expectJust
+ <$> Loader.getLoaderState interp
+ return $ expectJust $ lookupModuleEnv breakArrays ibi_info_mod
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
back n = moveHist (+n)
@@ -498,8 +505,8 @@ moveHist fn = do
span <- case mb_info of
Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>")
Just (bid, _ibi) -> liftIO $ do
- brks <- readModBreaks (hsc_HUG hsc_env) (bi_tick_mod bid)
- return $ modBreaks_locs brks ! bi_tick_index bid
+ (_, brks) <- readModBreaks (hsc_HUG hsc_env) (bi_tick_mod bid)
+ return $ modBreaks_locs brks ! bi_tick_index bid -- todo: getBreakLoc
(hsc_env1, names) <-
liftIO $ bindLocalsAtBreakpoint hsc_env apStack span (snd <$> mb_info)
let ic = hsc_IC hsc_env1
@@ -560,10 +567,10 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do
-- of the breakpoint and the free variables of the expression.
bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do
let hug = hsc_HUG hsc_env
- info_brks <- readModBreaks hug (ibi_info_mod ibi)
+ (info_brks, _) <- readModBreaks hug (ibi_info_mod ibi)
bid <- internalBreakIdToBreakId hug ibi
- tick_brks <- readModBreaks hug (bi_tick_mod bid)
- let info = expectJust $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks)
+ (_, tick_brks) <- readModBreaks hug (bi_tick_mod bid)
+ let info = expectJust $ IntMap.lookup (ibi_info_index ibi) (imodBreaks_breakInfo info_brks)
interp = hscInterp hsc_env
occs = modBreaks_vars tick_brks ! bi_tick_index bid
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -33,7 +33,6 @@ import GHC.Platform.Profile
import GHC.Runtime.Interpreter
import GHCi.FFI
-import GHCi.RemoteTypes
import GHC.Types.Basic
import GHC.Utils.Outputable
import GHC.Types.Name
@@ -81,17 +80,13 @@ import Control.Monad
import Data.Char
import GHC.Unit.Module
-import qualified GHC.Unit.Home.Graph as HUG
-import Data.Array
import Data.Coerce (coerce)
#if MIN_VERSION_rts(1,0,3)
import qualified Data.ByteString.Char8 as BS
#endif
import Data.Map (Map)
-import Data.IntMap (IntMap)
import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
import qualified GHC.Data.FiniteMap as Map
import Data.Ord
import Data.Either ( partitionEithers )
@@ -101,8 +96,8 @@ import qualified Data.IntSet as IntSet
import GHC.CoreToIface
import Control.Monad.IO.Class
-import Control.Monad.Trans.Reader (ReaderT)
-import Control.Monad.Trans.State (StateT)
+import Control.Monad.Trans.Reader (ReaderT(..))
+import Control.Monad.Trans.State (StateT(..))
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -128,8 +123,8 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
flattenBind (StgNonRec b e) = [(b,e)]
flattenBind (StgRec bs) = bs
- (BcM_State{..}, proto_bcos) <-
- runBc hsc_env this_mod mb_modBreaks $ do
+ (proto_bcos, BcM_State{..}) <-
+ runBc hsc_env this_mod $ do
let flattened_binds = concatMap flattenBind (reverse lifted_binds)
FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds
@@ -138,15 +133,12 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
(vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))
let all_mod_breaks = case mb_modBreaks of
- Just modBreaks -> Just (modBreaks, internalBreaks)
+ Just modBreaks -> Just (internalBreaks, modBreaks)
Nothing -> Nothing
-- no modBreaks, thus drop all
-- internalBreaks? Will we ever want to have internal breakpoints in
-- a module for which we're not doing breakpoints at all? probably
- -- not?
- -- TODO: Consider always returning InternalBreaks;
- -- TODO: Consider making ModBreaks a SUM that can be empty instead of using Maybe.
- cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries
+ cbc <- assembleBCOs profile proto_bcos tycs strings all_mod_breaks spt_entries
-- Squash space leaks in the CompiledByteCode. This is really
-- important, because when loading a set of modules into GHCi
@@ -409,7 +401,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do
current_mod <- getCurrentModule
liftIO (readModBreaksMaybe (hsc_HUG hsc_env) current_mod) >>= \case
Nothing -> pure code
- Just ModBreaks {modBreaks_flags = breaks, modBreaks_ccs = cc_arr} -> do
+ Just _ -> do
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
@@ -417,20 +409,13 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do
toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id
- let info_mod = current_mod
- infox <- newBreakInfo breakInfo
+ ibi <- newBreakInfo breakInfo
- let cc | Just interp <- hsc_interp hsc_env
- , interpreterProfiled interp
- = cc_arr ! bi_tick_index tick_id
- | otherwise = toRemotePtr nullPtr
-
- breakInstr = BRK_FUN breaks (InternalBreakpointId info_mod infox) cc
-
- return $ breakInstr `consOL` code
+ return $ BRK_FUN ibi `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
--- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module
+-- TODO: WHERE TO PUT
+-- Determine the GHCi-allocated 'BreakArray' and module pointer for the module
-- from which the breakpoint originates.
-- These are stored in 'ModBreaks' as remote pointers in order to allow the BCOs
-- to refer to pointers in GHCi's address space.
@@ -449,19 +434,6 @@ schemeER_wrk d p rhs = schemeE d 0 p rhs
-- If the breakpoint is inlined from another module, look it up in the HUG (home unit graph).
-- If the module doesn't exist there, or if the 'ModBreaks' value is
-- uninitialized, skip the instruction (i.e. return Nothing).
-break_info ::
- HscEnv ->
- Module ->
- Module ->
- Maybe ModBreaks ->
- BcM (Maybe ModBreaks)
-break_info hsc_env mod current_mod current_mod_breaks
- | mod == current_mod
- = pure current_mod_breaks
- | otherwise
- = liftIO (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case
- Just hp -> pure $ getModBreaks hp
- Nothing -> pure Nothing
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
getVarOffSets platform depth env = map getOffSet
@@ -2642,34 +2614,31 @@ data BcM_Env
= BcM_Env
{ bcm_hsc_env :: HscEnv
, bcm_module :: Module -- current module (for breakpoints)
- , bcm_mod_breaks :: Maybe ModBreaks -- this module's ModBreaks
}
data BcM_State
= BcM_State
{ nextlabel :: !Word32 -- ^ For generating local labels
, breakInfoIdx :: !Int -- ^ Next index for breakInfo array
- , internalBreaks :: InternalModBreaks
+ , internalBreaks :: !InternalModBreaks
-- ^ Info at breakpoints occurrences. Indexed with
-- 'InternalBreakpointId'. See Note [Breakpoint identifiers] in
-- GHC.ByteCode.Breakpoints.
}
-newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (BcM_State, r))
+newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State))
deriving (Functor, Applicative, Monad, MonadIO)
via (ReaderT BcM_Env (StateT BcM_State IO))
-runBc :: HscEnv -> Module -> Maybe ModBreaks
- -> BcM r
- -> IO (BcM_State, r)
-runBc hsc_env this_mod modBreaks (BcM m)
- = m (BcM_Env hsc_env this_mod modBreaks) (BcM_State 0 0 (mkInternalModBreaks this_mod mempty))
+runBc :: HscEnv -> Module -> BcM r -> IO (r, BcM_State)
+runBc hsc_env this_mod (BcM m)
+ = m (BcM_Env hsc_env this_mod) (BcM_State 0 0 (mkInternalModBreaks this_mod mempty))
instance HasDynFlags BcM where
getDynFlags = hsc_dflags <$> getHscEnv
getHscEnv :: BcM HscEnv
-getHscEnv = BcM $ \env st -> return (st, bcm_hsc_env env)
+getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st)
getProfile :: BcM Profile
getProfile = targetProfile <$> getDynFlags
@@ -2686,12 +2655,12 @@ getLabelBc = BcM $ \_ st ->
do let nl = nextlabel st
when (nl == maxBound) $
panic "getLabelBc: Ran out of labels"
- return (st{nextlabel = nl + 1}, LocalLabel nl)
+ return (LocalLabel nl, st{nextlabel = nl + 1})
getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc n = BcM $ \_ st ->
let ctr = nextlabel st
- in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
+ in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n})
newBreakInfo :: CgBreakInfo -> BcM InternalBreakpointId
newBreakInfo info = BcM $ \env st ->
@@ -2701,10 +2670,10 @@ newBreakInfo info = BcM $ \env st ->
{ internalBreaks = addInternalBreak ibi info (internalBreaks st)
, breakInfoIdx = ix + 1
}
- in return (st', ibi)
+ in return (ibi, st')
getCurrentModule :: BcM Module
-getCurrentModule = BcM $ \env st -> return (st, thisModule env)
+getCurrentModule = BcM $ \env st -> return (bcm_module env, st)
tickFS :: FastString
tickFS = fsLit "ticked"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3cbb38fecc7fad079204332299bc52…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3cbb38fecc7fad079204332299bc52…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Tick uses of wildcard/pun field binds as if using the record selector function
by Marge Bot (＠marge-bot) 27 Jun '25
by Marge Bot (＠marge-bot) 27 Jun '25
27 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9648af73 by Florian Ragwitz at 2025-06-27T09:30:47-04:00
Tick uses of wildcard/pun field binds as if using the record selector function
Fixes #17834.
See Note [Record-selector ticks] for additional reasoning behind this as well
as an overview of the implementation details and future improvements.
- - - - -
58bcdc47 by Ben Gamari at 2025-06-27T09:30:48-04:00
testsuite/caller-cc: Make CallerCc[123] less sensitive
These were previously sensitive to irrelevant changes in program
structure. To avoid this we filter out all by lines emitted by the
-fcaller-cc from the profile.
- - - - -
7 changed files:
- compiler/GHC/HsToCore/Ticks.hs
- docs/users_guide/9.14.1-notes.rst
- + testsuite/tests/hpc/recsel/Makefile
- + testsuite/tests/hpc/recsel/recsel.hs
- + testsuite/tests/hpc/recsel/recsel.stdout
- + testsuite/tests/hpc/recsel/test.T
- testsuite/tests/profiling/should_run/caller-cc/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -1,12 +1,11 @@
-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-
(c) Galois, 2006
(c) University of Glasgow, 2007
+(c) Florian Ragwitz, 2025
-}
module GHC.HsToCore.Ticks
@@ -38,7 +37,9 @@ import GHC.Utils.Logger
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Id
+import GHC.Types.Id.Info
import GHC.Types.Var.Set
+import GHC.Types.Var.Env
import GHC.Types.Name.Set hiding (FreeVars)
import GHC.Types.Name
import GHC.Types.CostCentre
@@ -48,6 +49,7 @@ import GHC.Types.ProfAuto
import Control.Monad
import Data.List (isSuffixOf, intersperse)
+import Data.Foldable (toList)
import Trace.Hpc.Mix
@@ -123,6 +125,7 @@ addTicksToBinds logger cfg
, density = mkDensity tickish $ ticks_profAuto cfg
, this_mod = mod
, tickishType = tickish
+ , recSelBinds = emptyVarEnv
}
(binds',_,st') = unTM (addTickLHsBinds binds) env st
in (binds', st')
@@ -224,8 +227,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
, abs_exports = abs_exports
}))) =
- withEnv add_exports $
- withEnv add_inlines $ do
+ withEnv (add_rec_sels . add_inlines . add_exports) $ do
binds' <- addTickLHsBinds binds
return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }
where
@@ -247,6 +249,12 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
| ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
, isInlinePragma (idInlinePragma pid) ] }
+ add_rec_sels env =
+ env{ recSelBinds = recSelBinds env `extendVarEnvList`
+ [ (abe_mono, abe_poly)
+ | ABE{ abe_poly, abe_mono } <- abs_exports
+ , RecSelId{} <- [idDetails abe_poly] ] }
+
addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do
let name = getOccString id
decl_path <- getPathEntry
@@ -261,6 +269,10 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
tickish <- tickishType `liftM` getEnv
case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do
+ -- See Note [Record-selector ticks]
+ selTick <- recSelTick id
+ case selTick of { Just tick -> tick_rec_sel tick; _ -> do
+
(fvs, mg) <-
getFreeVars $
addPathEntry name $
@@ -288,7 +300,40 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
let mbCons = maybe Prelude.id (:)
return $ L pos $ funBind { fun_matches = mg
, fun_ext = second (tick `mbCons`) (fun_ext funBind) }
- }
+ } }
+ where
+ -- See Note [Record-selector ticks]
+ tick_rec_sel tick =
+ pure $ L pos $ funBind { fun_ext = second (tick :) (fun_ext funBind) }
+
+
+-- Note [Record-selector ticks]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Users expect (see #17834) that accessing a record field by its name using
+-- NamedFieldPuns or RecordWildCards will mark it as covered. This is very
+-- reasonable, because otherwise the use of those two language features will
+-- produce unnecessary noise in coverage reports, distracting from real
+-- coverage problems.
+--
+-- Because of that, GHC chooses to treat record selectors specially for
+-- coverage purposes to improve the developer experience.
+--
+-- This is done by keeping track of which 'Id's are effectively bound to
+-- record fields (using NamedFieldPuns or RecordWildCards) in 'TickTransEnv's
+-- 'recSelBinds', and making 'HsVar's corresponding to those fields tick the
+-- appropriate box when executed.
+--
+-- To enable that, we also treat 'FunBind's for record selector functions
+-- specially. We only create a TopLevelBox for the record selector function,
+-- skipping the ExpBox that'd normally be created. This simplifies the re-use
+-- of ticks for the same record selector, and is done by not recursing into
+-- the fun_matches match group for record selector functions.
+--
+-- This scheme could be extended further in the future, making coverage for
+-- constructor fields (named or even positional) mean that the field was
+-- accessed at run-time. For the time being, we only cover NamedFieldPuns and
+-- RecordWildCards binds to cover most practical use-cases while keeping it
+-- simple.
-- TODO: Revisit this
addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
@@ -471,7 +516,10 @@ addBinTickLHsExpr boxLabel e@(L pos e0)
-- in the addTickLHsExpr family of functions.)
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
+-- See Note [Record-selector ticks]
+addTickHsExpr e@(HsVar _ (L _ id)) =
+ freeVar id >> recSelTick id >>= pure . maybe e wrap
+ where wrap tick = XExpr . HsTick tick . noLocA $ e
addTickHsExpr e@(HsIPVar {}) = return e
addTickHsExpr e@(HsOverLit {}) = return e
addTickHsExpr e@(HsOverLabel{}) = return e
@@ -532,7 +580,7 @@ addTickHsExpr (HsMultiIf ty alts)
; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts
; return $ HsMultiIf ty alts' }
addTickHsExpr (HsLet x binds e) =
- bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
+ bindLocals binds $ do
binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
e' <- addTickLHsExprLetBody e
return (HsLet x binds' e')
@@ -580,6 +628,7 @@ addTickHsExpr e@(HsUntypedSplice{}) = return e
addTickHsExpr e@(HsGetField {}) = return e
addTickHsExpr e@(HsProjection {}) = return e
addTickHsExpr (HsProc x pat cmdtop) =
+ bindLocals pat $
liftM2 (HsProc x)
(addTickLPat pat)
(traverse (addTickHsCmdTop) cmdtop)
@@ -646,19 +695,17 @@ addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} -> Match GhcTc (L
-> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats
, m_grhss = gRHSs }) =
- bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
+ bindLocals pats $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs
return $ match { m_grhss = gRHSs' }
addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) =
- bindLocals binders $ do
+ bindLocals local_binds $ do
local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded
return $ GRHSs x guarded' local_binds'
- where
- binders = collectLocalBinders CollNoDictBinders local_binds
addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
@@ -697,7 +744,7 @@ addTickLStmts isGuard stmts = do
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
-> TM ([ExprLStmt GhcTc], a)
addTickLStmts' isGuard lstmts res
- = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $
+ = bindLocals lstmts $
do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts
; a <- res
; return (lstmts', a) }
@@ -710,6 +757,7 @@ addTickStmt _isGuard (LastStmt x e noret ret) =
(pure noret)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt xbs pat e) =
+ bindLocals pat $
liftM4 (\b f -> BindStmt $ XBindStmtTc
{ xbstc_bindOp = b
, xbstc_boundResultType = xbstc_boundResultType xbs
@@ -770,17 +818,19 @@ addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where
addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
- ApplicativeArgOne
- <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
- <*> addTickLPat pat
- <*> addTickLHsExpr expr
- <*> pure isBody
+ bindLocals pat $
+ ApplicativeArgOne
+ <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
+ <*> addTickLPat pat
+ <*> addTickLHsExpr expr
+ <*> pure isBody
addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
- (ApplicativeArgMany x)
- <$> addTickLStmts isGuard stmts
- <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
- <*> addTickLPat pat
- <*> pure ctxt
+ bindLocals pat $
+ ApplicativeArgMany x
+ <$> addTickLStmts isGuard stmts
+ <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
+ <*> addTickLPat pat
+ <*> pure ctxt
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
@@ -871,7 +921,7 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
(addTickLHsCmd c2)
(addTickLHsCmd c3)
addTickHsCmd (HsCmdLet x binds c) =
- bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
+ bindLocals binds $ do
binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
c' <- addTickLHsCmd c
return (HsCmdLet x binds' c')
@@ -907,18 +957,16 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) =
- bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
+ bindLocals pats $ do
gRHSs' <- addTickCmdGRHSs gRHSs
return $ match { m_grhss = gRHSs' }
addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs (GRHSs x guarded local_binds) =
- bindLocals binders $ do
+ bindLocals local_binds $ do
local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (traverse addTickCmdGRHS) guarded
return $ GRHSs x guarded' local_binds'
- where
- binders = collectLocalBinders CollNoDictBinders local_binds
addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
-- The *guards* are *not* Cmds, although the body is
@@ -937,15 +985,14 @@ addTickLCmdStmts stmts = do
addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
-> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
addTickLCmdStmts' lstmts res
- = bindLocals binders $ do
+ = bindLocals lstmts $ do
lstmts' <- mapM (traverse addTickCmdStmt) lstmts
a <- res
return (lstmts', a)
- where
- binders = collectLStmtsBinders CollNoDictBinders lstmts
addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
addTickCmdStmt (BindStmt x pat c) =
+ bindLocals pat $
liftM2 (BindStmt x)
(addTickLPat pat)
(addTickLHsCmd c)
@@ -1006,11 +1053,13 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) =
data TickTransState = TT { ticks :: !(SizedSeq Tick)
, ccIndices :: !CostCentreState
+ , recSelTicks :: !(IdEnv CoreTickish)
}
initTTState :: TickTransState
initTTState = TT { ticks = emptySS
, ccIndices = newCostCentreState
+ , recSelTicks = emptyVarEnv
}
addMixEntry :: Tick -> TM Int
@@ -1021,6 +1070,10 @@ addMixEntry ent = do
}
return c
+addRecSelTick :: Id -> CoreTickish -> TM ()
+addRecSelTick sel tick =
+ setState $ \s -> s{ recSelTicks = extendVarEnv (recSelTicks s) sel tick }
+
data TickTransEnv = TTE { fileName :: FastString
, density :: TickDensity
, tte_countEntries :: !Bool
@@ -1033,6 +1086,7 @@ data TickTransEnv = TTE { fileName :: FastString
, blackList :: Set RealSrcSpan
, this_mod :: Module
, tickishType :: TickishType
+ , recSelBinds :: IdEnv Id
}
-- deriving Show
@@ -1154,12 +1208,13 @@ ifGoodTickSrcSpan pos then_code else_code = do
good <- isGoodTickSrcSpan pos
if good then then_code else else_code
-bindLocals :: [Id] -> TM a -> TM a
-bindLocals new_ids (TM m)
- = TM $ \ env st ->
- case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
- (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
- where occs = [ nameOccName (idName id) | id <- new_ids ]
+bindLocals :: (CollectBinders bndr, CollectFldBinders bndr) => bndr -> TM a -> TM a
+bindLocals from (TM m) = TM $ \env st ->
+ case m (with_bnds env) st of
+ (r, fv, st') -> (r, fv `delListFromOccEnv` (map (nameOccName . idName) new_bnds), st')
+ where with_bnds e = e{ inScope = inScope e `extendVarSetList` new_bnds
+ , recSelBinds = recSelBinds e `plusVarEnv` collectFldBinds from }
+ new_bnds = collectBinds from
withBlackListed :: SrcSpan -> TM a -> TM a
withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) })
@@ -1186,6 +1241,17 @@ allocTickBox boxLabel countEntries topOnly pos m
tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
return (this_loc (XExpr $ HsTick tickish $ this_loc e))
+recSelTick :: Id -> TM (Maybe CoreTickish)
+recSelTick id = ifDensity TickForCoverage maybe_tick (pure Nothing)
+ where
+ maybe_tick = getEnv >>=
+ maybe (pure Nothing) tick . (`lookupVarEnv` id) . recSelBinds
+ tick sel = getState >>=
+ maybe (alloc sel) (pure . Just) . (`lookupVarEnv` sel) . recSelTicks
+ alloc sel = allocATickBox (box sel) False False (getSrcSpan sel) noFVs
+ >>= traverse (\t -> t <$ addRecSelTick sel t)
+ box sel = TopLevelBox [getOccString sel]
+
-- the tick application inherits the source position of its
-- expression argument to support nested box allocations
allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
@@ -1288,3 +1354,98 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
matchCount :: LMatch GhcTc body -> Int
matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
= length grhss
+
+-- | Convenience class used by 'bindLocals' to collect new bindings from
+-- various parts of he AST. Just delegates to
+-- 'collect{Pat,Pats,Local,LStmts}Binders' from 'GHC.Hs.Utils' as appropriate.
+class CollectBinders a where
+ collectBinds :: a -> [Id]
+
+-- | Variant of 'CollectBinders' which collects information on which locals
+-- are bound to record fields (currently only via 'RecordWildCards' or
+-- 'NamedFieldPuns') to enable better coverage support for record selectors.
+--
+-- See Note [Record-selector ticks].
+class CollectFldBinders a where
+ collectFldBinds :: a -> IdEnv Id
+
+instance CollectBinders (LocatedA (Pat GhcTc)) where
+ collectBinds = collectPatBinders CollNoDictBinders
+instance CollectBinders [LocatedA (Pat GhcTc)] where
+ collectBinds = collectPatsBinders CollNoDictBinders
+instance CollectBinders (HsLocalBinds GhcTc) where
+ collectBinds = collectLocalBinders CollNoDictBinders
+instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsExpr GhcTc)))] where
+ collectBinds = collectLStmtsBinders CollNoDictBinders
+instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsCmd GhcTc)))] where
+ collectBinds = collectLStmtsBinders CollNoDictBinders
+
+instance (CollectFldBinders a) => CollectFldBinders [a] where
+ collectFldBinds = foldr (flip plusVarEnv . collectFldBinds) emptyVarEnv
+instance (CollectFldBinders e) => CollectFldBinders (GenLocated l e) where
+ collectFldBinds = collectFldBinds . unLoc
+instance CollectFldBinders (Pat GhcTc) where
+ collectFldBinds ConPat{ pat_args = RecCon HsRecFields{ rec_flds, rec_dotdot } } =
+ collectFldBinds rec_flds `plusVarEnv` plusVarEnvList (zipWith fld_bnds [0..] rec_flds)
+ where n_explicit | Just (L _ (RecFieldsDotDot n)) <- rec_dotdot = n
+ | otherwise = length rec_flds
+ fld_bnds n (L _ HsFieldBind{ hfbLHS = L _ FieldOcc{ foLabel = L _ sel }
+ , hfbRHS = L _ (VarPat _ (L _ var))
+ , hfbPun })
+ | hfbPun || n >= n_explicit = unitVarEnv var sel
+ fld_bnds _ _ = emptyVarEnv
+ collectFldBinds ConPat{ pat_args = PrefixCon pats } = collectFldBinds pats
+ collectFldBinds ConPat{ pat_args = InfixCon p1 p2 } = collectFldBinds [p1, p2]
+ collectFldBinds (LazyPat _ pat) = collectFldBinds pat
+ collectFldBinds (BangPat _ pat) = collectFldBinds pat
+ collectFldBinds (AsPat _ _ pat) = collectFldBinds pat
+ collectFldBinds (ViewPat _ _ pat) = collectFldBinds pat
+ collectFldBinds (ParPat _ pat) = collectFldBinds pat
+ collectFldBinds (ListPat _ pats) = collectFldBinds pats
+ collectFldBinds (TuplePat _ pats _) = collectFldBinds pats
+ collectFldBinds (SumPat _ pats _ _) = collectFldBinds pats
+ collectFldBinds (SigPat _ pat _) = collectFldBinds pat
+ collectFldBinds (XPat exp) = collectFldBinds exp
+ collectFldBinds VarPat{} = emptyVarEnv
+ collectFldBinds WildPat{} = emptyVarEnv
+ collectFldBinds OrPat{} = emptyVarEnv
+ collectFldBinds LitPat{} = emptyVarEnv
+ collectFldBinds NPat{} = emptyVarEnv
+ collectFldBinds NPlusKPat{} = emptyVarEnv
+ collectFldBinds SplicePat{} = emptyVarEnv
+ collectFldBinds EmbTyPat{} = emptyVarEnv
+ collectFldBinds InvisPat{} = emptyVarEnv
+instance (CollectFldBinders r) => CollectFldBinders (HsFieldBind l r) where
+ collectFldBinds = collectFldBinds . hfbRHS
+instance CollectFldBinders XXPatGhcTc where
+ collectFldBinds (CoPat _ pat _) = collectFldBinds pat
+ collectFldBinds (ExpansionPat _ pat) = collectFldBinds pat
+instance CollectFldBinders (HsLocalBinds GhcTc) where
+ collectFldBinds (HsValBinds _ bnds) = collectFldBinds bnds
+ collectFldBinds HsIPBinds{} = emptyVarEnv
+ collectFldBinds EmptyLocalBinds{} = emptyVarEnv
+instance CollectFldBinders (HsValBinds GhcTc) where
+ collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds
+ collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds)
+instance CollectFldBinders (HsBind GhcTc) where
+ collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs
+ collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) =
+ mkVarEnv [ (abe_poly, sel)
+ | ABE{ abe_poly, abe_mono } <- abs_exports
+ , Just sel <- [lookupVarEnv monos abe_mono] ]
+ where monos = collectFldBinds abs_binds
+ collectFldBinds VarBind{} = emptyVarEnv
+ collectFldBinds FunBind{} = emptyVarEnv
+ collectFldBinds PatSynBind{} = emptyVarEnv
+instance CollectFldBinders (Stmt GhcTc e) where
+ collectFldBinds (BindStmt _ pat _) = collectFldBinds pat
+ collectFldBinds (LetStmt _ bnds) = collectFldBinds bnds
+ collectFldBinds (ParStmt _ xs _ _) = collectFldBinds [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss]
+ collectFldBinds TransStmt{ trS_stmts } = collectFldBinds trS_stmts
+ collectFldBinds RecStmt{ recS_stmts } = collectFldBinds recS_stmts
+ collectFldBinds (XStmtLR (ApplicativeStmt _ args _)) = collectFldBinds (map snd args)
+ collectFldBinds LastStmt{} = emptyVarEnv
+ collectFldBinds BodyStmt{} = emptyVarEnv
+instance CollectFldBinders (ApplicativeArg GhcTc) where
+ collectFldBinds ApplicativeArgOne{ app_arg_pattern } = collectFldBinds app_arg_pattern
+ collectFldBinds ApplicativeArgMany{ bv_pattern } = collectFldBinds bv_pattern
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -138,6 +138,11 @@ Compiler
uses of the now deprecated ``pattern`` namespace specifier in import/export
lists. See `GHC Proposal #581, section 2.3 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0581-n…>`_.
+- Code coverage (:ghc-flag:`-fhpc`) now treats uses of record fields via
+ :extension:`RecordWildCards` or :extension:`NamedFieldPuns` as if the fields
+ were accessed using the generated record selector functions, marking the fields
+ as covered in coverage reports (:ghc-ticket:`17834`).
+
GHCi
~~~~
=====================================
testsuite/tests/hpc/recsel/Makefile
=====================================
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
=====================================
testsuite/tests/hpc/recsel/recsel.hs
=====================================
@@ -0,0 +1,49 @@
+{-# LANGUAGE RecordWildCards, NamedFieldPuns, Arrows #-}
+
+import Control.Monad.Identity
+import Control.Arrow (runKleisli, arr, returnA)
+import Data.Maybe
+import Data.List
+import Data.Bifunctor
+import Trace.Hpc.Mix
+import Trace.Hpc.Tix
+import Trace.Hpc.Reflect
+
+data Foo = Foo { fooA, fooB, fooC, fooD, fooE, fooF, fooG, fooH, fooI
+ , fooJ, fooK, fooL, fooM, fooN, fooO :: Int }
+data Bar = Bar { barFoo :: Foo }
+
+fAB Foo{..} = fooA + fooB
+fC Foo{fooC} = fooC
+fD x Foo{..} = fromMaybe 0 $ if x then Just fooD else Nothing
+fE Bar{barFoo = Foo{..}} = fooE
+fF Foo{fooF = f} = f
+fG f = let Foo{..} = f in fooG
+fH f = runIdentity $ do
+ Foo{..} <- pure f
+ return fooH
+fI f = runIdentity $ do
+ let Foo{..} = f
+ return fooI
+fJ f = [ fooJ | let Foo{..} = f ] !! 0
+fK = runIdentity . runKleisli (proc f -> do
+ Foo{..} <- arr id -< f
+ returnA -< fooK)
+fL = runIdentity . runKleisli (proc f -> do
+ let Foo{..} = f;
+ returnA -< fooL)
+fM f | Foo{..} <- f = fooM
+fN f = fooN f
+fO = runIdentity . runKleisli (proc Foo{..} -> returnA -< fooO)
+
+recSel (n, TopLevelBox [s]) | any (`isPrefixOf` s) ["foo", "bar"] = Just (n, s)
+recSel _ = Nothing
+
+main = do
+ let foo = Foo 42 23 0 1 2 3 4 5 6 7 0xaffe 9 10 11 12
+ mapM_ (print . ($ foo))
+ [fAB, fC, fD False, fE . Bar, fF, fG, fH, fI, fJ, fK, fL, fM, fN, fO]
+ (Mix _ _ _ _ mixs) <- readMix [".hpc"] (Left "Main")
+ let sels = mapMaybe recSel . zip [0..] $ map snd mixs
+ (Tix [TixModule "Main" _ _ tix]) <- examineTix
+ mapM_ print . sortOn snd $ map (first (tix !!)) sels
=====================================
testsuite/tests/hpc/recsel/recsel.stdout
=====================================
@@ -0,0 +1,30 @@
+65
+0
+0
+2
+3
+4
+5
+6
+7
+45054
+9
+10
+11
+12
+(0,"barFoo")
+(1,"fooA")
+(1,"fooB")
+(1,"fooC")
+(0,"fooD")
+(1,"fooE")
+(0,"fooF")
+(1,"fooG")
+(1,"fooH")
+(1,"fooI")
+(1,"fooJ")
+(1,"fooK")
+(1,"fooL")
+(1,"fooM")
+(1,"fooN")
+(1,"fooO")
=====================================
testsuite/tests/hpc/recsel/test.T
=====================================
@@ -0,0 +1,7 @@
+setTestOpts([omit_ghci, when(fast(), skip), js_skip])
+
+test('recsel',
+ [ignore_extension,
+ when(arch('wasm32'), fragile(23243))],
+ compile_and_run, ['-fhpc'])
+
=====================================
testsuite/tests/profiling/should_run/caller-cc/all.T
=====================================
@@ -8,6 +8,7 @@ setTestOpts(only_ways(prof_ways))
setTestOpts(extra_files(['Main.hs']))
setTestOpts(extra_run_opts('7'))
setTestOpts(grep_prof("Main.hs"))
+setTestOpts(grep_prof("calling:"))
# N.B. Main.hs is stolen from heapprof001.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/088cd94e524bd116e7844bed60a912…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/088cd94e524bd116e7844bed60a912…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC
Commits:
e0a933c6 by Simon Peyton Jones at 2025-06-27T08:41:57+01:00
Wibble imports
- - - - -
1 changed file:
- compiler/GHC/Tc/Utils/Monad.hs
Changes:
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -221,7 +221,6 @@ import GHC.Types.Name
import GHC.Types.SafeHaskell
import GHC.Types.Id
import GHC.Types.TypeEnv
-import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.SrcLoc
import GHC.Types.Name.Env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0a933c6be93291a601952910308e47…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0a933c6be93291a601952910308e47…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bump-win32-tarballs] 17 commits: configure: Don't force value of OTOOL, etc. if not present
by Ben Gamari (＠bgamari) 26 Jun '25
by Ben Gamari (＠bgamari) 26 Jun '25
26 Jun '25
Ben Gamari pushed to branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC
Commits:
83ee7b78 by Ben Gamari at 2025-06-24T05:02:07-04:00
configure: Don't force value of OTOOL, etc. if not present
Previously if `otool` and `install_name_tool` were not present they
would be overridden by `fp_settings.m4`. This logic was introduced in
4ff93292243888545da452ea4d4c1987f2343591 without explanation.
- - - - -
9329c9e1 by Ben Gamari at 2025-06-24T05:02:07-04:00
ghc-toolchain: Add support for otool, install_name_tool
Fixes part of ghc#23675.
- - - - -
25f5c998 by Ben Gamari at 2025-06-24T05:02:08-04:00
ghc-toolchain: Add support for llc, opt, llvm-as
Fixes #23675.
- - - - -
51d150dd by Rodrigo Mesquita at 2025-06-24T05:02:08-04:00
hadrian: Use settings-use-distro-mingw directly
The type `ToolchainSetting` only made sense when we had more settings to
fetch from the system config file. Even then "settings-use-distro-mingw"
is arguably not a toolchain setting.
With the fix for #23675, all toolchain tools were moved to the
`ghc-toolchain` `Toolchain` format. Therefore, we can inline
`settings-use-distro-mingw` accesses and delete `ToolchainSetting`.
- - - - -
dcf68a83 by Rodrigo Mesquita at 2025-06-24T05:02:08-04:00
configure: Check LlvmTarget exists for LlvmAsFlags
If LlvmTarget was empty, LlvmAsFlags would be just "--target=".
If it is empty now, simply keep LlvmAsFlags empty.
ghc-toolchain already does this right. This fix makes the two
configurations match up.
- - - - -
580a3353 by Ben Gamari at 2025-06-24T05:02:51-04:00
rts/linker/LoadArchive: Use bool
Improve type precision by using `bool` instead of `int` and `StgBool`.
- - - - -
76d1041d by Ben Gamari at 2025-06-24T05:02:51-04:00
rts/linker/LoadArchive: Don't rely on file extensions for identification
Previously archive members would be identified via their file extension,
as described in #13103. We now instead use a more principled approach,
relying on the magic number in the member's header.
As well, we refactor treatment of archive format detection to improve
code clarity and error handling.
Closes #13103.
- - - - -
4b748a99 by Teo Camarasu at 2025-06-24T15:31:07-04:00
template-haskell: improve changelog
stable -> more stable, just to clarify that this interface isn't fully stable.
errornously -> mistakenly: I typod this and also let's go for a simpler word
- - - - -
e358e477 by Sylvain Henry at 2025-06-24T15:31:58-04:00
Bump stack resolver to use GHC 9.6.7
Cf #26139
- - - - -
4bf5eb63 by fendor at 2025-06-25T17:05:43-04:00
Teach `:reload` about multiple home units
`:reload` needs to lookup the `ModuleName` and must not assume the given
`ModuleName` is in the current `HomeUnit`.
We add a new utility function which allows us to find a `HomeUnitModule`
instead of a `Module`.
Further, we introduce the `GhciCommandError` type which can be used to
abort the execution of a GHCi command.
This error is caught and printed in a human readable fashion.
- - - - -
b3d97bb3 by fendor at 2025-06-25T17:06:25-04:00
Implement `-fno-load-initial-targets` flag
We add the new flag `-fno-load-initial-targets` which doesn't load all `Target`s
immediately but only computes the module graph for all `Target`s.
The user can then decide to load modules from that module graph using
the syntax:
ghci> :reload <Mod>
This will load everything in the module graph up to `Mod`.
The user can return to the initial state by using the builtin target
`none` to unload all modules.
ghci> :reload none
Is in principle identical to starting a new session with the
`-fno-load-initial-targets` flag.
The `-fno-load-initial-targets` flag allows for faster startup time of GHCi when a
user has lots of `Target`s.
We additionally extend the `:reload` command to accept multiple
`ModuleName`s. For example:
ghci> :reload <Mod1> <Mod2>
Loads all modules up to the modules `Mod1` and `Mod2`.
- - - - -
49f44e52 by Teo Camarasu at 2025-06-26T04:19:51-04:00
Expose ghc-internal unit id through the settings file
This in combination with the unit id of the compiler library allows
cabal to know of the two unit ids that should not be reinstalled (in
specific circumstances) as:
- when using plugins, we want to link against exactly the compiler unit
id
- when using TemplateHaskell we want to link against exactly the package
that contains the TemplateHaskell interfaces, which is `ghc-internal`
See: <https://github.com/haskell/cabal/issues/10087>
Resolves #25282
- - - - -
499c4efe by Bryan Richter at 2025-06-26T04:20:33-04:00
CI: Fix and clean up capture of timings
* Fixes the typo that caused 'cat ci-timings' to report "no such file or
directory"
* Gave ci_timings.txt a file extension so it may play better with other
systems
* Fixed the use of time_it so all times are recorded
* Fixed time_it to print name along with timing
- - - - -
86c90c9e by Bryan Richter at 2025-06-26T04:20:33-04:00
CI: Update collapsible section usage
The syntax apparently changed at some point.
- - - - -
04308ee4 by Bryan Richter at 2025-06-26T04:20:33-04:00
CI: Add more collapsible sections
- - - - -
3f406ec8 by Ben Gamari at 2025-06-26T16:40:49-04:00
Bump win32-tarballs to v0.9
- - - - -
05aa9a1a by GHC GitLab CI at 2025-06-26T16:40:50-04:00
rts/LoadArchive: Handle null terminated string tables
- - - - -
66 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/common.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/Setup.hs
- distrib/configure.ac.in
- docs/users_guide/ghci.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- ghc/GHCi/UI/Print.hs
- hadrian/cfg/default.host.target.in
- hadrian/cfg/default.target.in
- hadrian/cfg/system.config.in
- hadrian/src/Builder.hs
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Builders/RunTest.hs
- hadrian/stack.yaml
- hadrian/stack.yaml.lock
- libraries/template-haskell/changelog.md
- m4/fp_settings.m4
- m4/ghc_toolchain.m4
- m4/prep_target_file.m4
- mk/get-win32-tarballs.py
- rts/linker/LoadArchive.c
- testsuite/tests/ghc-e/should_fail/T18441fail5.stderr
- testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr
- testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr
- + testsuite/tests/ghci/prog-mhu005/Makefile
- + testsuite/tests/ghci/prog-mhu005/a/A.hs
- + testsuite/tests/ghci/prog-mhu005/all.T
- + testsuite/tests/ghci/prog-mhu005/b/B.hs
- + testsuite/tests/ghci/prog-mhu005/prog-mhu005a.script
- + testsuite/tests/ghci/prog-mhu005/prog-mhu005a.stderr
- + testsuite/tests/ghci/prog-mhu005/prog-mhu005a.stdout
- + testsuite/tests/ghci/prog-mhu005/unitA
- + testsuite/tests/ghci/prog-mhu005/unitB
- + testsuite/tests/ghci/prog021/A.hs
- + testsuite/tests/ghci/prog021/B.hs
- + testsuite/tests/ghci/prog021/Makefile
- + testsuite/tests/ghci/prog021/all.T
- + testsuite/tests/ghci/prog021/prog021a.script
- + testsuite/tests/ghci/prog021/prog021a.stderr
- + testsuite/tests/ghci/prog021/prog021a.stdout
- + testsuite/tests/ghci/prog021/prog021b.script
- + testsuite/tests/ghci/prog021/prog021b.stderr
- + testsuite/tests/ghci/prog021/prog021b.stdout
- + testsuite/tests/ghci/prog022/A.hs
- + testsuite/tests/ghci/prog022/B.hs
- + testsuite/tests/ghci/prog022/Makefile
- + testsuite/tests/ghci/prog022/all.T
- + testsuite/tests/ghci/prog022/ghci.prog022a.script
- + testsuite/tests/ghci/prog022/ghci.prog022a.stderr
- + testsuite/tests/ghci/prog022/ghci.prog022a.stdout
- + testsuite/tests/ghci/prog022/ghci.prog022b.script
- + testsuite/tests/ghci/prog022/ghci.prog022b.stderr
- + testsuite/tests/ghci/prog022/ghci.prog022b.stdout
- testsuite/tests/ghci/scripts/ghci021.stderr
- utils/ghc-toolchain/exe/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6f3eb04a2d015bf658ea380879eaa1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6f3eb04a2d015bf658ea380879eaa1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
26 Jun '25
Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC
Commits:
4b02492f by Simon Peyton Jones at 2025-06-26T23:40:31+01:00
Fix two significant bugs
- - - - -
7 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -1086,14 +1086,25 @@ matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
-- Look up the predicate in Given quantified constraints,
-- which are effectively just local instance declarations.
matchLocalInst body_pred loc
- = do { inerts@(IS { inert_cans = ics }) <- getInertSet
+ = do { -- In TcSShortCut mode we do not look at Givens;
+ -- c.f. tryInertDicts
+ mode <- getTcSMode
+ ; case mode of
+ { TcSShortCut -> do { traceTcS "matchLocalInst:TcSShortCut" (ppr body_pred)
+ ; return NoInstance }
+ ; _other ->
+
+ do { -- Look in the inert set for a matching Given quantified constraint
+ inerts@(IS { inert_cans = ics }) <- getInertSet
; case match_local_inst inerts (inert_insts ics) of
{ ([], []) -> do { traceTcS "No local instance for" (ppr body_pred)
; return NoInstance }
; (matches, unifs) ->
- do { matches <- mapM mk_instDFun matches
- ; unifs <- mapM mk_instDFun unifs
+
+ do { -- Find the best match
-- See Note [Use only the best matching quantified constraint]
+ matches <- mapM mk_instDFun matches
+ ; unifs <- mapM mk_instDFun unifs
; case dominatingMatch matches of
{ Just (dfun_id, tys, theta)
| all ((theta `impliedBySCs`) . thdOf3) unifs
@@ -1115,7 +1126,7 @@ matchLocalInst body_pred loc
, text "matches:" <+> ppr matches
, text "unifs:" <+> ppr unifs
, text "best_match:" <+> ppr mb_best ]
- ; return NotSure }}}}}
+ ; return NotSure }}}}}}}
where
body_pred_tv_set = tyCoVarsOfType body_pred
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -545,7 +545,9 @@ can_eq_nc_forall ev eq_rel s1 s2
, ic_wanted = emptyWC { wc_simple = wanteds } }
; if solved
- then do { setWantedEq orig_dest all_co
+ then do { zonked_all_co <- zonkCo all_co
+ -- ToDo: explain this zonk
+ ; setWantedEq orig_dest zonked_all_co
; stopWith ev "Polytype equality: solved" }
else canEqSoftFailure IrredShapeReason ev s1 s2 } }
@@ -572,7 +574,8 @@ can_eq_nc_forall ev eq_rel s1 s2
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To solve an equality between foralls
[W] (forall a. t1) ~ (forall b. t2)
-the basic plan is simple: just create the implication constraint
+the basic plan is simple: use `trySolveImplication` to solve the
+implication constraint
[W] forall a. { t1 ~ (t2[a/b]) }
The evidence we produce is a ForAllCo; see the typing rule for
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1435,7 +1435,7 @@ getTcEvBindsVar = TcS (return . tcs_ev_binds)
getTcLevel :: TcS TcLevel
getTcLevel = wrapTcS TcM.getTcLevel
-getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet
+getTcEvTyCoVars :: EvBindsVar -> TcS [TcCoercion]
getTcEvTyCoVars ev_binds_var
= wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var
@@ -1989,19 +1989,15 @@ setEvBind ev_bind
; wrapTcS $ TcM.addTcEvBind evb ev_bind }
-- | Mark variables as used filling a coercion hole
-useVars :: CoVarSet -> TcS ()
-useVars co_vars
+addUsedCoercion :: TcCoercion -> TcS ()
+addUsedCoercion co
= do { ev_binds_var <- getTcEvBindsVar
- ; let ref = ebv_tcvs ev_binds_var
- ; wrapTcS $
- do { tcvs <- TcM.readTcRef ref
- ; let tcvs' = tcvs `unionVarSet` co_vars
- ; TcM.writeTcRef ref tcvs' } }
+ ; wrapTcS (TcM.updTcRef (ebv_tcvs ev_binds_var) (co :)) }
-- | Equalities only
-setWantedEq :: HasDebugCallStack => TcEvDest -> Coercion -> TcS ()
+setWantedEq :: HasDebugCallStack => TcEvDest -> TcCoercion -> TcS ()
setWantedEq (HoleDest hole) co
- = do { useVars (coVarsOfCo co)
+ = do { addUsedCoercion co
; fillCoercionHole hole co }
setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)
@@ -2009,7 +2005,7 @@ setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)
setWantedEvTerm :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS ()
setWantedEvTerm (HoleDest hole) _canonical tm
| Just co <- evTermCoercion_maybe tm
- = do { useVars (coVarsOfCo co)
+ = do { addUsedCoercion co
; fillCoercionHole hole co }
| otherwise
= -- See Note [Yukky eq_sel for a HoleDest]
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Tc.Solver.Monad as TcS
import GHC.Core.Predicate
import GHC.Core.Reduction
import GHC.Core.Coercion
+import GHC.Core.TyCo.FVs( coVarsOfCos )
import GHC.Core.Class( classHasSCs )
import GHC.Types.Id( idType )
@@ -546,7 +547,7 @@ neededEvVars implic@(Implic { ic_info = info
, ic_need_implic = old_need_implic -- See (TRC1)
})
= do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var
- ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var
+ ; used_cos <- TcS.getTcEvTyCoVars ev_binds_var
; let -- Find the variables needed by `implics`
new_need_implic@(ENS { ens_dms = dm_seeds, ens_fvs = other_seeds })
@@ -556,7 +557,8 @@ neededEvVars implic@(Implic { ic_info = info
-- Get the variables needed by the solved bindings
-- (It's OK to use a non-deterministic fold here
-- because add_wanted is commutative.)
- seeds_w = nonDetStrictFoldEvBindMap add_wanted tcvs ev_binds
+ used_covars = coVarsOfCos used_cos
+ seeds_w = nonDetStrictFoldEvBindMap add_wanted used_covars ev_binds
need_ignoring_dms = findNeededGivenEvVars ev_binds (other_seeds `unionVarSet` seeds_w)
need_from_dms = findNeededGivenEvVars ev_binds dm_seeds
@@ -577,7 +579,7 @@ neededEvVars implic@(Implic { ic_info = info
; traceTcS "neededEvVars" $
vcat [ text "old_need_implic:" <+> ppr old_need_implic
, text "new_need_implic:" <+> ppr new_need_implic
- , text "tcvs:" <+> ppr tcvs
+ , text "used_covars:" <+> ppr used_covars
, text "need_ignoring_dms:" <+> ppr need_ignoring_dms
, text "need_from_dms:" <+> ppr need_from_dms
, text "need:" <+> ppr need
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -360,11 +360,13 @@ data EvBindsVar
-- (dictionaries etc)
-- Some Given, some Wanted
- ebv_tcvs :: IORef CoVarSet
- -- The free Given coercion vars needed by Wanted coercions that
- -- are solved by filling in their HoleDest in-place. Since they
- -- don't appear in ebv_binds, we keep track of their free
- -- variables so that we can report unused given constraints
+ ebv_tcvs :: IORef [TcCoercion]
+ -- When we solve a Wanted by filling in a CoercionHole, it is as
+ -- if we were adding an evidence binding
+ -- co_hole := coercion
+ -- We keep all these RHS coercions in a list, alongside `ebv_binds`,
+ -- so that we can report unused given constraints,
+ -- in GHC.Tc.Solver.neededEvVars
-- See Note [Tracking redundant constraints] in GHC.Tc.Solver
}
@@ -372,7 +374,7 @@ data EvBindsVar
-- See above for comments on ebv_uniq, ebv_tcvs
ebv_uniq :: Unique,
- ebv_tcvs :: IORef CoVarSet
+ ebv_tcvs :: IORef [TcCoercion]
}
instance Data.Data TcEvBinds where
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1762,7 +1762,7 @@ addTopEvBinds new_ev_binds thing_inside
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
- ; tcvs_ref <- newTcRef emptyVarSet
+ ; tcvs_ref <- newTcRef []
; uniq <- newUnique
; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
; return (EvBindsVar { ebv_binds = binds_ref
@@ -1774,7 +1774,7 @@ newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
-- must be made monadically
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds
- = do { tcvs_ref <- newTcRef emptyVarSet
+ = do { tcvs_ref <- newTcRef []
; uniq <- newUnique
; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
@@ -1785,14 +1785,14 @@ cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
-- solving don't pollute the original
cloneEvBindsVar ebv@(EvBindsVar {})
= do { binds_ref <- newTcRef emptyEvBindMap
- ; tcvs_ref <- newTcRef emptyVarSet
+ ; tcvs_ref <- newTcRef []
; return (ebv { ebv_binds = binds_ref
, ebv_tcvs = tcvs_ref }) }
cloneEvBindsVar ebv@(CoEvBindsVar {})
- = do { tcvs_ref <- newTcRef emptyVarSet
+ = do { tcvs_ref <- newTcRef []
; return (ebv { ebv_tcvs = tcvs_ref }) }
-getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
+getTcEvTyCoVars :: EvBindsVar -> TcM [TcCoercion]
getTcEvTyCoVars ev_binds_var
= readTcRef (ebv_tcvs ev_binds_var)
@@ -1817,15 +1817,15 @@ updTcEvBinds (EvBindsVar { ebv_binds = old_ebv_ref, ebv_tcvs = old_tcv_ref })
= do { new_ebvs <- readTcRef new_ebv_ref
; updTcRef old_ebv_ref (`unionEvBindMap` new_ebvs)
; new_tcvs <- readTcRef new_tcv_ref
- ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) }
+ ; updTcRef old_tcv_ref (new_tcvs ++) }
updTcEvBinds (EvBindsVar { ebv_tcvs = old_tcv_ref })
(CoEvBindsVar { ebv_tcvs = new_tcv_ref })
= do { new_tcvs <- readTcRef new_tcv_ref
- ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) }
+ ; updTcRef old_tcv_ref (new_tcvs ++) }
updTcEvBinds (CoEvBindsVar { ebv_tcvs = old_tcv_ref })
(CoEvBindsVar { ebv_tcvs = new_tcv_ref })
= do { new_tcvs <- readTcRef new_tcv_ref
- ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) }
+ ; updTcRef old_tcv_ref (new_tcvs ++) }
updTcEvBinds old_var new_var
= pprPanic "updTcEvBinds" (ppr old_var $$ ppr new_var)
-- Terms inside types, no good
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -2444,14 +2444,11 @@ checkTypeHasFixedRuntimeRep prov ty =
unless (typeHasFixedRuntimeRep ty)
(addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov)
-{-
-%************************************************************************
-%* *
+{- **********************************************************************
+* *
Error messages
* *
-*************************************************************************
-
--}
+********************************************************************** -}
-- See Note [Naughty quantification candidates]
naughtyQuantification :: TcType -- original type user wanted to quantify
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b02492f969c106ed3c733393ef159c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b02492f969c106ed3c733393ef159c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
26 Jun '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-8 at Glasgow Haskell Compiler / GHC
Commits:
3cbb38fe by Rodrigo Mesquita at 2025-06-26T16:27:12+01:00
littel better
- - - - -
1 changed file:
- compiler/GHC/StgToByteCode.hs
Changes:
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -2666,10 +2666,10 @@ runBc hsc_env this_mod modBreaks (BcM m)
= m (BcM_Env hsc_env this_mod modBreaks) (BcM_State 0 0 (mkInternalModBreaks this_mod mempty))
instance HasDynFlags BcM where
- getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
+ getDynFlags = hsc_dflags <$> getHscEnv
getHscEnv :: BcM HscEnv
-getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
+getHscEnv = BcM $ \env st -> return (st, bcm_hsc_env env)
getProfile :: BcM Profile
getProfile = targetProfile <$> getDynFlags
@@ -2682,16 +2682,16 @@ shouldAddBcoName = do
else return Nothing
getLabelBc :: BcM LocalLabel
-getLabelBc
- = BcM $ \st -> do let nl = nextlabel st
- when (nl == maxBound) $
- panic "getLabelBc: Ran out of labels"
- return (st{nextlabel = nl + 1}, LocalLabel nl)
+getLabelBc = BcM $ \_ st ->
+ do let nl = nextlabel st
+ when (nl == maxBound) $
+ panic "getLabelBc: Ran out of labels"
+ return (st{nextlabel = nl + 1}, LocalLabel nl)
getLabelsBc :: Word32 -> BcM [LocalLabel]
-getLabelsBc n
- = BcM $ \st -> let ctr = nextlabel st
- in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
+getLabelsBc n = BcM $ \_ st ->
+ let ctr = nextlabel st
+ in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
newBreakInfo :: CgBreakInfo -> BcM InternalBreakpointId
newBreakInfo info = BcM $ \env st ->
@@ -2704,7 +2704,7 @@ newBreakInfo info = BcM $ \env st ->
in return (st', ibi)
getCurrentModule :: BcM Module
-getCurrentModule = BcM $ \st -> return (st, thisModule st)
+getCurrentModule = BcM $ \env st -> return (st, thisModule env)
tickFS :: FastString
tickFS = fsLit "ticked"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3cbb38fecc7fad079204332299bc527…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3cbb38fecc7fad079204332299bc527…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/step-out-8] 2 commits: Continue refactor
by Rodrigo Mesquita (＠alt-romes) 26 Jun '25
by Rodrigo Mesquita (＠alt-romes) 26 Jun '25
26 Jun '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-8 at Glasgow Haskell Compiler / GHC
Commits:
178dd899 by Rodrigo Mesquita at 2025-06-26T14:22:39+01:00
Continue refactor
- - - - -
f084188e by Rodrigo Mesquita at 2025-06-26T16:20:46+01:00
Lots of progress
- - - - -
21 changed files:
- compiler/GHC/ByteCode/Asm.hs
- + compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Eval/Types.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- compiler/GHC/StgToByteCode.hs
- − compiler/GHC/Types/Breakpoint.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Unit/External.hs
- compiler/GHC/Unit/Module/ModGuts.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -31,7 +31,6 @@ import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord )
-import GHC.Types.Breakpoint
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Literal
@@ -74,6 +73,7 @@ import GHC.Float (castFloatToWord32, castDoubleToWord64)
import qualified Data.List as List ( any )
import GHC.Exts
+import GHC.HsToCore.Breakpoints (ModBreaks(..))
-- -----------------------------------------------------------------------------
@@ -111,7 +111,7 @@ assembleBCOs
-> FlatBag (ProtoBCO Name)
-> [TyCon]
-> [(Name, ByteString)]
- -> Maybe ModBreaks
+ -> Maybe (InternalModBreaks, ModBreaks)
-> [SptEntry]
-> IO CompiledByteCode
assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -0,0 +1,210 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Breakpoint information constructed during ByteCode generation.
+--
+-- Specifically, code-generation breakpoints are referred to as "internal
+-- breakpoints", the internal breakpoint data for a module is stored in
+-- 'InternalModBreaks', and is uniquely identified at runtime by an
+-- 'InternalBreakpointId'.
+--
+-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]
+module GHC.ByteCode.Breakpoints
+ ( -- * Internal Mod Breaks
+ InternalModBreaks(imodBreaks_breakInfo), CgBreakInfo(..)
+ , mkInternalModBreaks
+
+ -- ** Operations
+ , getInternalBreak, addInternalBreak
+
+ -- ** Internal breakpoint identifier
+ , InternalBreakpointId(..), BreakInfoIndex
+
+ -- * Utils
+ , seqInternalModBreaks
+
+ )
+ where
+
+import GHC.Prelude
+import Control.DeepSeq
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IM
+
+import GHC.Iface.Syntax
+import GHC.Types.Tickish
+
+import GHC.Unit.Module (Module)
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
+{-
+Note [ModBreaks vs InternalModBreaks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'ModBreaks' and 'BreakpointId's must not to be confused with
+'InternalModBreaks' and 'InternalBreakId's.
+
+'ModBreaks' is constructed once during HsToCore from the information attached
+to source-level breakpoint ticks and is never changed afterwards. A 'ModBreaks'
+can be queried using 'BreakpointId's, which uniquely identifies a breakpoint
+within the list of breakpoint information for a given module's 'ModBreaks'.
+
+'InternalModBreaks' are constructed during bytecode generation and are indexed
+by a 'InternalBreakpointId'. They contain all the information relevant to a
+breakpoint for code generation that can be accessed during runtime execution
+(such as a 'BreakArray' for triggering breakpoints). 'InternalBreakpointId's
+are used at runtime to trigger and inspect breakpoints -- a 'BRK_FUN'
+instruction receives 'InternalBreakpointId' as an argument.
+
+We keep a mapping from 'InternalModBreaks' to a 'BreakpointId', which can then be used
+to get source-level information about a breakpoint via the corresponding 'ModBreaks'.
+
+Notably, 'InternalModBreaks' can contain entries for so-called internal
+breakpoints, which do not necessarily have a source-level location attached to
+it (i.e. do not have a matching entry in 'ModBreaks'). We may leverage this to
+introduce breakpoints during code generation for features such as stepping-out.
+
+Note [Breakpoint identifiers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before optimization a breakpoint is identified uniquely with a tick module
+and a tick index. See 'BreakpointId'. A tick module contains an array, indexed
+with the tick indexes, which indicates breakpoint status.
+
+When we generate ByteCode, we collect information for every breakpoint at
+their *occurrence sites* (see CgBreakInfo) and these info
+are stored in the ModIface of the occurrence module. Because of inlining, we
+can't reuse the tick index to uniquely identify an occurrence; because of
+cross-module inlining, we can't assume that the occurrence module is the same
+as the tick module (#24712).
+
+So every breakpoint occurrence gets assigned a module-unique *info index* and
+we store it alongside the occurrence module (*info module*) in the
+'InternalBreakpointId' datatype. This is the index that we use at runtime to
+identify a breakpoint.
+
+When the internal breakpoint has a matching tick-level breakpoint we can fetch
+the related tick-level information by first looking up a mapping
+@'InternalBreakpointId' -> 'BreakpointId'@. See `internalBreakIdToBreakId`
+-}
+
+--------------------------------------------------------------------------------
+-- * Internal breakpoint identifiers
+--------------------------------------------------------------------------------
+
+-- | Internal breakpoint info index
+type BreakInfoIndex = Int
+
+-- | Internal breakpoint identifier
+--
+-- Indexes into the structures in the @'InternalModBreaks'@ produced during ByteCode generation.
+-- See Note [Breakpoint identifiers]
+data InternalBreakpointId = InternalBreakpointId
+ { ibi_info_mod :: !Module -- ^ Breakpoint tick module
+ , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint tick index
+ }
+ deriving (Eq, Ord)
+
+--------------------------------------------------------------------------------
+-- * Internal Mod Breaks
+--------------------------------------------------------------------------------
+
+-- | Internal mod breaks store the runtime-relevant information of breakpoints.
+--
+-- Importantly, it maps 'InternalBreakpointId's to 'CgBreakInfo'.
+--
+-- 'InternalModBreaks' are constructed during bytecode generation and stored in
+-- 'CompiledByteCode' afterwards.
+data InternalModBreaks = InternalModBreaks
+ { imodBreaks_breakInfo :: IntMap CgBreakInfo
+ -- ^ Access code-gen time information about a breakpoint, indexed by
+ -- 'InternalBreakpointId'.
+ , imodBreaks_module :: !Module
+ -- ^ Cache the module corresponding to these 'InternalModBreaks' for
+ -- sanity checks. Don't export it!
+ }
+
+-- | Construct an 'InternalModBreaks'
+mkInternalModBreaks :: Module -> IntMap CgBreakInfo -> InternalModBreaks
+mkInternalModBreaks mod im = InternalModBreaks im mod
+
+-- | Information about a breakpoint that we know at code-generation time
+-- In order to be used, this needs to be hydrated relative to the current HscEnv by
+-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for
+-- preventing space leaks (see #22530)
+data CgBreakInfo
+ = CgBreakInfo
+ { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
+ , cgb_vars :: ![Maybe (IfaceIdBndr, Word)]
+ , cgb_resty :: !IfaceType
+ , cgb_tick_id :: !BreakpointId
+ -- ^ This field records the original breakpoint tick identifier for this
+ -- internal breakpoint info. See Note [Breakpoint identifiers].
+ }
+-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
+
+-- | Get an internal breakpoint info by 'InternalBreakpointId'
+getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo
+getInternalBreak (InternalBreakpointId mod ix) imbs =
+ assert_modules_match mod (imodBreaks_module imbs) $
+ imodBreaks_breakInfo imbs IM.! ix
+
+-- | Add a CgBreakInfo to an 'InternalModBreaks' at 'InternalBreakpointId'
+addInternalBreak :: InternalBreakpointId -> CgBreakInfo -> InternalModBreaks -> InternalModBreaks
+addInternalBreak (InternalBreakpointId mod ix) info imbs =
+ assert_modules_match mod (imodBreaks_module imbs) $
+ imbs{imodBreaks_breakInfo = IM.insert ix info (imodBreaks_breakInfo imbs)}
+
+-- | Assert that the module in the 'InternalBreakpointId' and in
+-- 'InternalModBreaks' match.
+assert_modules_match :: Module -> Module -> a -> a
+assert_modules_match ibi_mod imbs_mod =
+ assertPpr (ibi_mod == imbs_mod)
+ (text "Tried to query the InternalModBreaks of module" <+> ppr imbs_mod
+ <+> text "with an InternalBreakpointId for module" <+> ppr ibi_mod)
+
+-- TODO: See what Cheng has in .
+-- mkCCSArray
+-- :: Interp -> Module -> Int -> [Tick]
+-- -> IO (Array BreakTickIndex (RemotePtr GHC.Stack.CCS.CostCentre))
+-- mkCCSArray interp modul count entries
+-- | interpreterProfiled interp = do
+-- let module_str = moduleNameString (moduleName modul)
+-- costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)
+-- return (listArray (0,count-1) costcentres)
+-- | otherwise = return (listArray (0,-1) [])
+-- where
+-- mk_one t = (name, src)
+-- where name = concat $ intersperse "." $ tick_path t
+-- src = renderWithContext defaultSDocContext $ ppr $ tick_loc t
+-- , modBreaks_ccs :: !(Array BreakTickIndex (RemotePtr CostCentre))
+-- -- ^ Array pointing to cost centre for each breakpoint
+-- ccs <- mkCCSArray interpProfiled mod count entries
+
+--------------------------------------------------------------------------------
+-- Instances
+--------------------------------------------------------------------------------
+
+-- | Fully force an 'InternalModBreaks' value
+seqInternalModBreaks :: InternalModBreaks -> ()
+seqInternalModBreaks InternalModBreaks{..} =
+ rnf (fmap seqCgBreakInfo imodBreaks_breakInfo)
+ where
+ seqCgBreakInfo :: CgBreakInfo -> ()
+ seqCgBreakInfo CgBreakInfo{..} =
+ rnf cgb_tyvars `seq`
+ rnf cgb_vars `seq`
+ rnf cgb_resty `seq`
+ rnf cgb_tick_id
+
+instance Outputable InternalBreakpointId where
+ ppr InternalBreakpointId{..} =
+ text "InternalBreakpointId" <+> ppr ibi_info_mod <+> ppr ibi_info_index
+
+instance NFData InternalBreakpointId where
+ rnf InternalBreakpointId{..} =
+ rnf ibi_info_mod `seq` rnf ibi_info_index
+
+instance Outputable CgBreakInfo where
+ ppr info = text "CgBreakInfo" <+>
+ parens (ppr (cgb_vars info) <+>
+ ppr (cgb_resty info) <+>
+ ppr (cgb_tick_id info))
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -36,7 +36,6 @@ import GHC.Stack.CCS (CostCentre)
import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
-import GHC.Types.Breakpoint
-- ----------------------------------------------------------------------------
-- Bytecode instructions
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -18,15 +18,17 @@ module GHC.ByteCode.Types
, UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
, ItblEnv, ItblPtr(..)
, AddrEnv, AddrPtr(..)
- , CgBreakInfo(..)
- , ModBreaks (..)
- , CCostCentre
, FlatBag, sizeFlatBag, fromSmallArray, elemsFlatBag
+
+ -- * Internal Mod Breaks
+ , InternalModBreaks(..), CgBreakInfo(..), seqInternalModBreaks
+ -- ** Internal breakpoint identifier
+ , InternalBreakpointId(..), BreakInfoIndex
) where
import GHC.Prelude
-import GHC.Types.Breakpoint
+import GHC.ByteCode.Breakpoints
import GHC.Data.FastString
import GHC.Data.FlatBag
import GHC.Types.Name
@@ -34,7 +36,6 @@ import GHC.Types.Name.Env
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
import GHC.Types.SptEntry
-import GHC.Types.SrcLoc
import GHCi.BreakArray
import GHCi.Message
import GHCi.RemoteTypes
@@ -43,14 +44,10 @@ import Control.DeepSeq
import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray )
import Foreign
-import Data.Array
import Data.ByteString (ByteString)
-import Data.IntMap (IntMap)
import qualified GHC.Exts.Heap as Heap
-import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
-import GHC.Iface.Syntax
-import GHC.Unit.Module (Module)
+import GHC.HsToCore.Breakpoints (ModBreaks)
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -65,8 +62,12 @@ data CompiledByteCode = CompiledByteCode
, bc_strs :: [(Name, ByteString)]
-- ^ top-level strings (heap allocated)
- , bc_breaks :: Maybe ModBreaks
- -- ^ breakpoint info (Nothing if breakpoints are disabled)
+ , bc_breaks :: (Maybe (InternalModBreaks, ModBreaks))
+ -- ^ internal breakpoint info (no tick-level 'ModBreaks' if breakpoints are disabled)
+ --
+ -- TODO: If ModBreaks is serialized and reconstructed as part of ModDetails
+ -- we don't need to keep it here as it can be fetched from the
+ -- 'HomeModInfo' directly.
, bc_spt_entries :: ![SptEntry]
-- ^ Static pointer table entries which should be loaded along with the
@@ -87,8 +88,8 @@ seqCompiledByteCode :: CompiledByteCode -> ()
seqCompiledByteCode CompiledByteCode{..} =
rnf bc_bcos `seq`
rnf bc_itbls `seq`
- rnf bc_strs `seq`
- rnf (fmap seqModBreaks bc_breaks)
+ rnf bc_strs
+ -- TODO: Add here something if new.
newtype ByteOff = ByteOff Int
deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)
@@ -282,82 +283,9 @@ data BCONPtr
instance NFData BCONPtr where
rnf x = x `seq` ()
--- | Information about a breakpoint that we know at code-generation time
--- In order to be used, this needs to be hydrated relative to the current HscEnv by
--- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for
--- preventing space leaks (see #22530)
-data CgBreakInfo
- = CgBreakInfo
- { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
- , cgb_vars :: ![Maybe (IfaceIdBndr, Word)]
- , cgb_resty :: !IfaceType
- , cgb_tick_id :: !BreakpointId
- -- ^ This field records the original breakpoint tick identifier for this
- -- internal breakpoint info. See Note [Breakpoint identifiers].
- }
--- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
-
-seqCgBreakInfo :: CgBreakInfo -> ()
-seqCgBreakInfo CgBreakInfo{..} =
- rnf cgb_tyvars `seq`
- rnf cgb_vars `seq`
- rnf cgb_resty `seq`
- rnf cgb_tick_id
-
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
= sep [text "BCO", ppr nm, text "with",
ppr (sizeFlatBag lits), text "lits",
ppr (sizeFlatBag ptrs), text "ptrs" ]
-instance Outputable CgBreakInfo where
- ppr info = text "CgBreakInfo" <+>
- parens (ppr (cgb_vars info) <+>
- ppr (cgb_resty info) <+>
- ppr (cgb_tick_id info))
-
--- -----------------------------------------------------------------------------
--- Breakpoints
-
--- | C CostCentre type
-data CCostCentre
-
--- | All the information about the breakpoints for a module
-data ModBreaks
- = ModBreaks
- { modBreaks_flags :: !(ForeignRef BreakArray)
- -- ^ The array of flags, one per breakpoint,
- -- indicating which breakpoints are enabled.
- , modBreaks_locs :: !(Array BreakTickIndex SrcSpan)
- -- ^ An array giving the source span of each breakpoint.
- , modBreaks_vars :: !(Array BreakTickIndex [OccName])
- -- ^ An array giving the names of the free variables at each breakpoint.
- , modBreaks_decls :: !(Array BreakTickIndex [String])
- -- ^ An array giving the names of the declarations enclosing each breakpoint.
- -- See Note [Field modBreaks_decls]
- , modBreaks_ccs :: !(Array BreakTickIndex (RemotePtr CostCentre))
- -- ^ Array pointing to cost centre for each breakpoint
- , modBreaks_breakInfo :: IntMap CgBreakInfo
- -- ^ info about each breakpoint from the bytecode generator
- , modBreaks_module :: !Module
- -- ^ info about the module in which we are setting the breakpoint
- }
-
-seqModBreaks :: ModBreaks -> ()
-seqModBreaks ModBreaks{..} =
- rnf modBreaks_flags `seq`
- rnf modBreaks_locs `seq`
- rnf modBreaks_vars `seq`
- rnf modBreaks_decls `seq`
- rnf modBreaks_ccs `seq`
- rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`
- rnf modBreaks_module
-
-{-
-Note [Field modBreaks_decls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A value of eg ["foo", "bar", "baz"] in a `modBreaks_decls` field means:
-The breakpoint is in the function called "baz" that is declared in a `let`
-or `where` clause of a declaration called "bar", which itself is declared
-in a `let` or `where` clause of the top-level function called "foo".
--}
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -31,7 +31,6 @@ import GHC.Prelude
import GHC.Core
import GHC.Core.Stats (exprStats)
-import GHC.Types.Breakpoint
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Literal( pprLiteral )
import GHC.Types.Name( pprInfixName, pprPrefixName )
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -72,7 +72,6 @@ import GHC.Iface.Syntax
import GHC.Data.FastString
import GHC.Data.BooleanFormula qualified as BF(BooleanFormula(..))
-import GHC.Types.Breakpoint
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make ( noinlineIdName, noinlineConstraintIdName )
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -97,7 +97,6 @@ import GHC.Unit.Module.Deps
import Data.List (partition)
import Data.IORef
-import Data.Traversable (for)
import GHC.Iface.Make (mkRecompUsageInfo)
{-
@@ -162,13 +161,12 @@ deSugar hsc_env
mod mod_loc
export_set (typeEnvTyCons type_env) binds
else return (binds, Nothing)
- ; modBreaks <- for
- [ (i, s)
- | i <- hsc_interp hsc_env
- , (_, s) <- m_tickInfo
- , breakpointsAllowed dflags
- ]
- $ \(interp, specs) -> mkModBreaks interp mod specs
+ ; let modBreaks
+ | Just (_, specs) <- m_tickInfo
+ , breakpointsAllowed dflags
+ = Just $ mkModBreaks mod specs
+ | otherwise
+ = Nothing
; ds_hpc_info <- case m_tickInfo of
Just (orig_file2, ticks)
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -1,25 +1,67 @@
+-- | Information attached to Breakpoints generated from Ticks
+--
+-- The breakpoint information stored in 'ModBreaks' is generated during
+-- desugaring from the ticks annotating the source expressions.
+--
+-- This information can be queried per-breakpoint using the 'BreakpointId'
+-- datatype, which indexes tick-level breakpoint information.
+--
+-- 'ModBreaks' and 'BreakpointId's are not to be confused with
+-- 'InternalModBreaks' and 'InternalBreakId's. The latter are constructed
+-- during bytecode generation and can be found in 'GHC.ByteCode.Breakpoints'.
+--
+-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]
module GHC.HsToCore.Breakpoints
- ( mkModBreaks
+ ( -- * ModBreaks
+ mkModBreaks, ModBreaks(modBreaks_locs, modBreaks_vars, modBreaks_decls)
+
+ -- ** Queries
+ , getBreakLoc, getBreakVars, getBreakDecls
+
+ -- ** Re-exports BreakpointId
+ , BreakpointId(..), BreakTickIndex
) where
import GHC.Prelude
-
-import qualified GHC.Runtime.Interpreter as GHCi
-import GHC.Runtime.Interpreter.Types
-import GHCi.RemoteTypes
-import GHC.ByteCode.Types
-import GHC.Stack.CCS
-import GHC.Unit
+import Data.Array
import GHC.HsToCore.Ticks (Tick (..))
-
import GHC.Data.SizedSeq
-import GHC.Utils.Outputable as Outputable
+import GHC.Types.SrcLoc (SrcSpan)
+import GHC.Types.Name (OccName)
+import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..))
+import GHC.Unit.Module (Module)
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
-import Data.List (intersperse)
-import Data.Array
-import qualified Data.IntMap as IntMap
-import GHC.Types.Breakpoint
+--------------------------------------------------------------------------------
+-- ModBreaks
+--------------------------------------------------------------------------------
+
+-- | All the information about the source-relevant breakpoints for a module
+--
+-- This information is constructed once during desugaring (with `mkModBreaks`)
+-- from breakpoint ticks and fixed/unchanged from there on forward. It could be
+-- exported as an abstract datatype because it should never be updated after
+-- construction, only queried.
+--
+-- The arrays can be indexed using the int in the corresponding 'BreakpointId'
+-- (i.e. the 'BreakpointId' whose 'Module' matches the 'Module' corresponding
+-- to these 'ModBreaks') with the accessors 'modBreaks_locs', 'modBreaks_vars',
+-- and 'modBreaks_decls'.
+data ModBreaks
+ = ModBreaks
+ { modBreaks_locs :: !(Array BreakTickIndex SrcSpan)
+ -- ^ An array giving the source span of each breakpoint.
+ , modBreaks_vars :: !(Array BreakTickIndex [OccName])
+ -- ^ An array giving the names of the free variables at each breakpoint.
+ , modBreaks_decls :: !(Array BreakTickIndex [String])
+ -- ^ An array giving the names of the declarations enclosing each breakpoint.
+ -- See Note [Field modBreaks_decls]
+ , modBreaks_module :: !Module
+ -- ^ The module to which this ModBreaks is associated.
+ -- We cache this here for internal sanity checks (don't export it!).
+ }
-- | Initialize memory for breakpoint data that is shared between the bytecode
-- generator and the interpreter.
@@ -28,38 +70,48 @@ import GHC.Types.Breakpoint
-- generator needs to encode this information for each expression, the data is
-- allocated remotely in GHCi's address space and passed to the codegen as
-- foreign pointers.
-mkModBreaks :: Interp -> Module -> SizedSeq Tick -> IO ModBreaks
-mkModBreaks interp mod extendedMixEntries
- = do
- let count = fromIntegral $ sizeSS extendedMixEntries
+mkModBreaks :: Module -> SizedSeq Tick -> ModBreaks
+mkModBreaks modl extendedMixEntries
+ = let count = fromIntegral $ sizeSS extendedMixEntries
entries = ssElts extendedMixEntries
-
- breakArray <- GHCi.newBreakArray interp count
- ccs <- mkCCSArray interp mod count entries
- let
- locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
- varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
- declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
- return $ ModBreaks
- { modBreaks_flags = breakArray
- , modBreaks_locs = locsTicks
+ locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
+ varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
+ declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
+ in ModBreaks
+ { modBreaks_locs = locsTicks
, modBreaks_vars = varsTicks
, modBreaks_decls = declsTicks
- , modBreaks_ccs = ccs
- , modBreaks_breakInfo = IntMap.empty
- , modBreaks_module = mod
+ , modBreaks_module = modl
}
-mkCCSArray
- :: Interp -> Module -> Int -> [Tick]
- -> IO (Array BreakTickIndex (RemotePtr GHC.Stack.CCS.CostCentre))
-mkCCSArray interp modul count entries
- | GHCi.interpreterProfiled interp = do
- let module_str = moduleNameString (moduleName modul)
- costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)
- return (listArray (0,count-1) costcentres)
- | otherwise = return (listArray (0,-1) [])
- where
- mk_one t = (name, src)
- where name = concat $ intersperse "." $ tick_path t
- src = renderWithContext defaultSDocContext $ ppr $ tick_loc t
+-- | Get the source span for this breakpoint
+getBreakLoc :: BreakpointId -> ModBreaks -> SrcSpan
+getBreakLoc (BreakpointId bid_mod ix) mbs =
+ assert_modules_match bid_mod (modBreaks_module mbs) $ modBreaks_locs mbs ! ix
+
+-- | Get the vars for this breakpoint
+getBreakVars :: BreakpointId -> ModBreaks -> [OccName]
+getBreakVars (BreakpointId bid_mod ix) mbs =
+ assert_modules_match bid_mod (modBreaks_module mbs) $ modBreaks_vars mbs ! ix
+
+-- | Get the decls for this breakpoint
+getBreakDecls :: BreakpointId -> ModBreaks -> [String]
+getBreakDecls (BreakpointId bid_mod ix) mbs =
+ assert_modules_match bid_mod (modBreaks_module mbs) $ modBreaks_decls mbs ! ix
+
+-- | Assert that the module in the 'BreakpointId' and in 'ModBreaks' match.
+assert_modules_match :: Module -> Module -> a -> a
+assert_modules_match bid_mod mbs_mod =
+ assertPpr (bid_mod == mbs_mod)
+ (text "Tried to query the ModBreaks of module" <+> ppr mbs_mod
+ <+> text "with a BreakpointId for module" <+> ppr bid_mod)
+
+{-
+Note [Field modBreaks_decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A value of eg ["foo", "bar", "baz"] in a `modBreaks_decls` field means:
+The breakpoint is in the function called "baz" that is declared in a `let`
+or `where` clause of a declaration called "bar", which itself is declared
+in a `let` or `where` clause of the top-level function called "foo".
+-}
+
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -55,7 +55,6 @@ import Data.Bifunctor (second)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Set (Set)
import qualified Data.Set as Set
-import GHC.Types.Breakpoint (BreakpointId(..))
{-
************************************************************************
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -56,7 +56,6 @@ import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)
import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey,
constraintKindTyConKey )
-import GHC.Types.Breakpoint
import GHC.Types.Unique ( hasKey )
import GHC.Iface.Type
import GHC.Iface.Recomp.Binary
@@ -75,6 +74,7 @@ import GHC.Types.Avail
import GHC.Types.ForeignCall
import GHC.Types.Annotations( AnnPayload, AnnTarget )
import GHC.Types.Basic
+import GHC.Types.Tickish
import GHC.Unit.Module
import GHC.Unit.Module.Warnings
import GHC.Types.SrcLoc
=====================================
compiler/GHC/Runtime/Debugger/Breakpoints.hs
=====================================
@@ -22,7 +22,6 @@ import GHC.Driver.Monad
import GHC.Driver.Session.Inspect
import GHC.Runtime.Eval
import GHC.Runtime.Eval.Utils
-import GHC.Types.Breakpoint
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Unit.Module
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -705,6 +705,7 @@ pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
{-
Note [Syncing breakpoint info]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ROMES:TODO: Update
To display the values of the free variables for a single breakpoint, the
function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` pulls
out the information from the fields `modBreaks_breakInfo` and
=====================================
compiler/GHC/Runtime/Eval/Types.hs
=====================================
@@ -17,17 +17,18 @@ import GHC.Prelude
import GHCi.RemoteTypes
import GHCi.Message (EvalExpr, ResumeContext)
+import GHC.ByteCode.Types (InternalBreakpointId(..))
import GHC.Driver.Config (EvalStep(..))
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.TyThing
-import GHC.Types.Breakpoint
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Utils.Exception
import Data.Word
import GHC.Stack.CCS
+import GHC.Types.Tickish (BreakpointId)
data ExecOptions
= ExecOptions
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -28,11 +28,10 @@ module GHC.Runtime.Interpreter
, whereFrom
, getModBreaks
, readModBreaks
+ , readModBreaksMaybe
, seqHValue
, evalBreakpointToId
, internalBreakIdToBreakId
- , interpreterDynamic
- , interpreterProfiled
-- * The object-code linker
, initObjLinker
@@ -77,9 +76,10 @@ import GHCi.Message
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray (BreakArray)
-import GHC.Types.Breakpoint
-import GHC.ByteCode.Types
+import GHC.HsToCore.Breakpoints
+import GHC.ByteCode.Breakpoints
+import GHC.ByteCode.Types
import GHC.Linker.Types
import GHC.Data.Maybe
@@ -123,7 +123,6 @@ import qualified GHC.Unit.Home.Graph as HUG
-- Standard libraries
import GHC.Exts
-import qualified Data.IntMap as IntMap
{- Note [Remote GHCi]
~~~~~~~~~~~~~~~~~~
@@ -434,9 +433,8 @@ evalBreakpointToId eval_break =
-- See also Note [Breakpoint identifiers]
internalBreakIdToBreakId :: HomeUnitGraph -> InternalBreakpointId -> IO BreakpointId
internalBreakIdToBreakId hug ibi = do
- ModBreaks{modBreaks_breakInfo} <- readModBreaks hug (ibi_info_mod ibi)
- let CgBreakInfo{cgb_tick_id} = expectJust $
- IntMap.lookup (ibi_info_index ibi) modBreaks_breakInfo
+ (imbs, _) <- readModBreaks hug (ibi_info_mod ibi)
+ let CgBreakInfo{cgb_tick_id} = getInternalBreak ibi imbs
return cgb_tick_id
-- | Process the result of a Seq or ResumeSeq message. #2950
@@ -467,7 +465,7 @@ handleSeqHValueStatus interp unit_env eval_status =
-- Nothing case - should not occur! We should have the appropriate
-- breakpoint information
Nothing -> nothing_case
- Just modbreaks -> put $ brackets . ppr $ (modBreaks_locs modbreaks) ! bi_tick_index bi
+ Just (_, modbreaks) -> put $ brackets . ppr $ (modBreaks_locs modbreaks) ! bi_tick_index bi
-- resume the seq (:force) processing in the iserv process
withForeignRef resume_ctxt_fhv $ \hval -> do
@@ -747,10 +745,13 @@ wormholeRef interp _r = case interpInstance interp of
ExternalInterp {}
-> throwIO (InstallationError "this operation requires -fno-external-interpreter")
--- -----------------------------------------------------------------------------
--- Misc utils
+--------------------------------------------------------------------------------
+-- * Finding breakpoint information
+--------------------------------------------------------------------------------
-getModBreaks :: HomeModInfo -> Maybe ModBreaks
+-- | Get the breakpoint information from the ByteCode object associated to this
+-- 'HomeModInfo'.
+getModBreaks :: HomeModInfo -> Maybe (InternalModBreaks, ModBreaks)
getModBreaks hmi
| Just linkable <- homeModInfoByteCode hmi,
-- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
@@ -759,33 +760,18 @@ getModBreaks hmi
| otherwise
= Nothing -- probably object code
--- | Read the 'ModBreaks' of the given home 'Module' from the 'HomeUnitGraph'.
-readModBreaks :: HomeUnitGraph -> Module -> IO ModBreaks
-readModBreaks hug mod =
- expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule mod hug
+-- | Read the 'InternalModBreaks' and 'ModBreaks' of the given home 'Module'
+-- from the 'HomeUnitGraph'.
+readModBreaks :: HomeUnitGraph -> Module -> IO (InternalModBreaks, ModBreaks)
+readModBreaks hug mod = expectJust <$> readModBreaksMaybe hug mod
+
+readModBreaksMaybe :: HomeUnitGraph -> Module -> IO (Maybe (InternalModBreaks, ModBreaks))
+readModBreaksMaybe hug mod = getModBreaks . expectJust <$> HUG.lookupHugByModule mod hug
+
+-- -----------------------------------------------------------------------------
+-- Misc utils
fromEvalResult :: EvalResult a -> IO a
fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
fromEvalResult (EvalSuccess a) = return a
--- | Interpreter uses Profiling way
-interpreterProfiled :: Interp -> Bool
-interpreterProfiled interp = case interpInstance interp of
-#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> hostIsProfiled
-#endif
- ExternalInterp ext -> case ext of
- ExtIServ i -> iservConfProfiled (interpConfig i)
- ExtJS {} -> False -- we don't support profiling yet in the JS backend
- ExtWasm i -> wasmInterpProfiled $ interpConfig i
-
--- | Interpreter uses Dynamic way
-interpreterDynamic :: Interp -> Bool
-interpreterDynamic interp = case interpInstance interp of
-#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> hostIsDynamic
-#endif
- ExternalInterp ext -> case ext of
- ExtIServ i -> iservConfDynamic (interpConfig i)
- ExtJS {} -> False -- dynamic doesn't make sense for JS
- ExtWasm {} -> True -- wasm dyld can only load dynamic code
=====================================
compiler/GHC/Runtime/Interpreter/Types.hs
=====================================
@@ -24,7 +24,8 @@ module GHC.Runtime.Interpreter.Types
, interpSymbolSuffix
, eliminateInterpSymbol
, interpretedInterpSymbol
-
+ , interpreterProfiled
+ , interpreterDynamic
-- * IServ
, IServ
@@ -136,6 +137,28 @@ data ExtInterpInstance c = ExtInterpInstance
-- ^ Instance specific extra fields
}
+-- | Interpreter uses Profiling way
+interpreterProfiled :: Interp -> Bool
+interpreterProfiled interp = case interpInstance interp of
+#if defined(HAVE_INTERNAL_INTERPRETER)
+ InternalInterp -> hostIsProfiled
+#endif
+ ExternalInterp ext -> case ext of
+ ExtIServ i -> iservConfProfiled (interpConfig i)
+ ExtJS {} -> False -- we don't support profiling yet in the JS backend
+ ExtWasm i -> wasmInterpProfiled $ interpConfig i
+
+-- | Interpreter uses Dynamic way
+interpreterDynamic :: Interp -> Bool
+interpreterDynamic interp = case interpInstance interp of
+#if defined(HAVE_INTERNAL_INTERPRETER)
+ InternalInterp -> hostIsDynamic
+#endif
+ ExternalInterp ext -> case ext of
+ ExtIServ i -> iservConfDynamic (interpConfig i)
+ ExtJS {} -> False -- dynamic doesn't make sense for JS
+ ExtWasm {} -> True -- wasm dyld can only load dynamic code
+
------------------------
-- JS Stuff
------------------------
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -4,13 +4,14 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DerivingVia #-}
--
-- (c) The University of Glasgow 2002-2006
--
-- | GHC.StgToByteCode: Generate bytecode from STG
-module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where
+module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen ) where
import GHC.Prelude
@@ -70,7 +71,8 @@ import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Tickish
import GHC.Types.SptEntry
-import GHC.Types.Breakpoint
+import GHC.HsToCore.Breakpoints
+import GHC.ByteCode.Breakpoints
import Data.List ( genericReplicate, intersperse
, partition, scanl', sortBy, zip4, zip6 )
@@ -98,6 +100,10 @@ import GHC.Stg.Syntax
import qualified Data.IntSet as IntSet
import GHC.CoreToIface
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Reader (ReaderT)
+import Control.Monad.Trans.State (StateT)
+
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -131,9 +137,15 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
"Proto-BCOs" FormatByteCode
(vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))
- let mod_breaks = case modBreaks of
- Nothing -> Nothing
- Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }
+ let all_mod_breaks = case mb_modBreaks of
+ Just modBreaks -> Just (modBreaks, internalBreaks)
+ Nothing -> Nothing
+ -- no modBreaks, thus drop all
+ -- internalBreaks? Will we ever want to have internal breakpoints in
+ -- a module for which we're not doing breakpoints at all? probably
+ -- not?
+ -- TODO: Consider always returning InternalBreaks;
+ -- TODO: Consider making ModBreaks a SUM that can be empty instead of using Maybe.
cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries
-- Squash space leaks in the CompiledByteCode. This is really
@@ -314,7 +326,7 @@ schemeTopBind (id, rhs)
-- because mkConAppCode treats nullary constructor applications
-- by just re-using the single top-level definition. So
-- for the worker itself, we must allocate it directly.
- -- ioToBc (putStrLn $ "top level BCO")
+ -- liftIO (putStrLn $ "top level BCO")
pure (mkProtoBCO platform add_bco_name
(getName id) (toOL [PACK data_con 0, RETURN P])
(Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
@@ -395,32 +407,27 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do
code <- schemeE d 0 p rhs
hsc_env <- getHscEnv
current_mod <- getCurrentModule
- mb_current_mod_breaks <- getCurrentModBreaks
- case mb_current_mod_breaks of
- -- if we're not generating ModBreaks for this module for some reason, we
- -- can't store breakpoint occurrence information.
+ liftIO (readModBreaksMaybe (hsc_HUG hsc_env) current_mod) >>= \case
Nothing -> pure code
- Just current_mod_breaks -> break_info hsc_env (bi_tick_mod tick_id) current_mod mb_current_mod_breaks >>= \case
- Nothing -> pure code
- Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = _tick_mod, modBreaks_ccs = cc_arr} -> do
- platform <- profilePlatform <$> getProfile
- let idOffSets = getVarOffSets platform d p fvs
- ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
- toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
- toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
- breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id
+ Just ModBreaks {modBreaks_flags = breaks, modBreaks_ccs = cc_arr} -> do
+ platform <- profilePlatform <$> getProfile
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id
- let info_mod = modBreaks_module current_mod_breaks
- infox <- newBreakInfo breakInfo
+ let info_mod = current_mod
+ infox <- newBreakInfo breakInfo
- let cc | Just interp <- hsc_interp hsc_env
- , interpreterProfiled interp
- = cc_arr ! bi_tick_index tick_id
- | otherwise = toRemotePtr nullPtr
+ let cc | Just interp <- hsc_interp hsc_env
+ , interpreterProfiled interp
+ = cc_arr ! bi_tick_index tick_id
+ | otherwise = toRemotePtr nullPtr
- breakInstr = BRK_FUN breaks (InternalBreakpointId info_mod infox) cc
+ breakInstr = BRK_FUN breaks (InternalBreakpointId info_mod infox) cc
- return $ breakInstr `consOL` code
+ return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
-- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module
@@ -452,7 +459,7 @@ break_info hsc_env mod current_mod current_mod_breaks
| mod == current_mod
= pure current_mod_breaks
| otherwise
- = ioToBc (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case
+ = liftIO (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case
Just hp -> pure $ getModBreaks hp
Nothing -> pure Nothing
@@ -2630,57 +2637,33 @@ typeArgReps platform = map (toArgRep platform) . typePrimRep
-- -----------------------------------------------------------------------------
-- The bytecode generator's monad
+-- | Read only environment for generating ByteCode
+data BcM_Env
+ = BcM_Env
+ { bcm_hsc_env :: HscEnv
+ , bcm_module :: Module -- current module (for breakpoints)
+ , bcm_mod_breaks :: Maybe ModBreaks -- this module's ModBreaks
+ }
+
data BcM_State
= BcM_State
- { bcm_hsc_env :: HscEnv
- , thisModule :: Module -- current module (for breakpoints)
- , nextlabel :: Word32 -- for generating local labels
- , modBreaks :: Maybe ModBreaks -- info about breakpoints
-
- , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence.
- -- Indexed with breakpoint *info* index.
- -- See Note [Breakpoint identifiers]
- -- in GHC.Types.Breakpoint
- , breakInfoIdx :: !Int -- ^ Next index for breakInfo array
+ { nextlabel :: !Word32 -- ^ For generating local labels
+ , breakInfoIdx :: !Int -- ^ Next index for breakInfo array
+ , internalBreaks :: InternalModBreaks
+ -- ^ Info at breakpoints occurrences. Indexed with
+ -- 'InternalBreakpointId'. See Note [Breakpoint identifiers] in
+ -- GHC.ByteCode.Breakpoints.
}
-newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)
-
-ioToBc :: IO a -> BcM a
-ioToBc io = BcM $ \st -> do
- x <- io
- return (st, x)
+newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (BcM_State, r))
+ deriving (Functor, Applicative, Monad, MonadIO)
+ via (ReaderT BcM_Env (StateT BcM_State IO))
runBc :: HscEnv -> Module -> Maybe ModBreaks
-> BcM r
-> IO (BcM_State, r)
runBc hsc_env this_mod modBreaks (BcM m)
- = m (BcM_State hsc_env this_mod 0 modBreaks IntMap.empty 0)
-
-thenBc :: BcM a -> (a -> BcM b) -> BcM b
-thenBc (BcM expr) cont = BcM $ \st0 -> do
- (st1, q) <- expr st0
- let BcM k = cont q
- (st2, r) <- k st1
- return (st2, r)
-
-thenBc_ :: BcM a -> BcM b -> BcM b
-thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
- (st1, _) <- expr st0
- (st2, r) <- cont st1
- return (st2, r)
-
-returnBc :: a -> BcM a
-returnBc result = BcM $ \st -> (return (st, result))
-
-instance Applicative BcM where
- pure = returnBc
- (<*>) = ap
- (*>) = thenBc_
-
-instance Monad BcM where
- (>>=) = thenBc
- (>>) = (*>)
+ = m (BcM_Env hsc_env this_mod modBreaks) (BcM_State 0 0 (mkInternalModBreaks this_mod mempty))
instance HasDynFlags BcM where
getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
@@ -2710,20 +2693,18 @@ getLabelsBc n
= BcM $ \st -> let ctr = nextlabel st
in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
-newBreakInfo :: CgBreakInfo -> BcM Int
-newBreakInfo info = BcM $ \st ->
+newBreakInfo :: CgBreakInfo -> BcM InternalBreakpointId
+newBreakInfo info = BcM $ \env st ->
let ix = breakInfoIdx st
+ ibi = InternalBreakpointId (bcm_module env) ix
st' = st
- { breakInfo = IntMap.insert ix info (breakInfo st)
- , breakInfoIdx = ix + 1
- }
- in return (st', ix)
+ { internalBreaks = addInternalBreak ibi info (internalBreaks st)
+ , breakInfoIdx = ix + 1
+ }
+ in return (st', ibi)
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \st -> return (st, thisModule st)
-getCurrentModBreaks :: BcM (Maybe ModBreaks)
-getCurrentModBreaks = BcM $ \st -> return (st, modBreaks st)
-
tickFS :: FastString
tickFS = fsLit "ticked"
=====================================
compiler/GHC/Types/Breakpoint.hs deleted
=====================================
@@ -1,77 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
--- | Breakpoint related types
-module GHC.Types.Breakpoint
- ( BreakpointId (..)
- , InternalBreakpointId (..)
- , BreakTickIndex, BreakInfoIndex
- )
-where
-
-import Control.DeepSeq
-import GHC.Prelude
-import GHC.Unit.Module
-import GHC.Utils.Outputable
-import Data.Data (Data)
-
--- | Breakpoint tick index
-type BreakTickIndex = Int
-
--- | Internal breakpoint info index
-type BreakInfoIndex = Int
-
--- | Breakpoint identifier.
---
--- See Note [Breakpoint identifiers]
-data BreakpointId = BreakpointId
- { bi_tick_mod :: !Module -- ^ Breakpoint tick module
- , bi_tick_index :: !BreakTickIndex -- ^ Breakpoint tick index
- }
- deriving (Eq, Ord, Data)
-
--- | Internal breakpoint identifier
---
--- See Note [Breakpoint identifiers]
-data InternalBreakpointId = InternalBreakpointId
- { ibi_info_mod :: !Module -- ^ Breakpoint tick module
- , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint tick index
- }
- deriving (Eq, Ord)
-
--- Note [Breakpoint identifiers]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- ROMES:TODO: UPDATE NOTE
--- Before optimization a breakpoint is identified uniquely with a tick module
--- and a tick index. See BreakpointId. A tick module contains an array, indexed
--- with the tick indexes, which indicates breakpoint status.
---
--- When we generate ByteCode, we collect information for every breakpoint at
--- their *occurrence sites* (see CgBreakInfo in GHC.ByteCode.Types) and these info
--- are stored in the ModIface of the occurrence module. Because of inlining, we
--- can't reuse the tick index to uniquely identify an occurrence; because of
--- cross-module inlining, we can't assume that the occurrence module is the same
--- as the tick module (#24712).
---
--- So every breakpoint occurrence gets assigned a module-unique *info index* and
--- we store it alongside the occurrence module (*info module*) in the
--- InternalBreakpointId datatype.
-
---------------------------------------------------------------------------------
--- Instances
---------------------------------------------------------------------------------
-
-instance Outputable BreakpointId where
- ppr BreakpointId{..} =
- text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index
-
-instance Outputable InternalBreakpointId where
- ppr InternalBreakpointId{..} =
- text "InternalBreakpointId" <+> ppr ibi_info_mod <+> ppr ibi_info_index
-
-instance NFData BreakpointId where
- rnf BreakpointId{..} =
- rnf bi_tick_mod `seq` rnf bi_tick_index
-
-instance NFData InternalBreakpointId where
- rnf InternalBreakpointId{..} =
- rnf ibi_info_mod `seq` rnf ibi_info_index
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -21,11 +21,15 @@ module GHC.Types.Tickish (
isProfTick,
TickishPlacement(..),
tickishPlace,
- tickishContains
+ tickishContains,
+
+ -- * Breakpoint tick identifiers
+ BreakpointId(..), BreakTickIndex
) where
import GHC.Prelude
import GHC.Data.FastString
+import Control.DeepSeq
import GHC.Core.Type
@@ -40,8 +44,7 @@ import GHC.Utils.Panic
import Language.Haskell.Syntax.Extension ( NoExtField )
import Data.Data
-import GHC.Utils.Outputable (Outputable (ppr), text)
-import GHC.Types.Breakpoint
+import GHC.Utils.Outputable (Outputable (ppr), text, (<+>))
{- *********************************************************************
* *
@@ -171,6 +174,33 @@ deriving instance Eq (GenTickish 'TickishPassCmm)
deriving instance Ord (GenTickish 'TickishPassCmm)
deriving instance Data (GenTickish 'TickishPassCmm)
+--------------------------------------------------------------------------------
+-- Tick breakpoint index
+--------------------------------------------------------------------------------
+
+-- | Breakpoint tick index
+type BreakTickIndex = Int
+
+-- | Breakpoint identifier.
+--
+-- Indexes into the structures in the @'ModBreaks'@ created during desugaring
+-- (after inserting the breakpoint ticks in the expressions).
+-- See Note [Breakpoint identifiers]
+data BreakpointId = BreakpointId
+ { bi_tick_mod :: !Module -- ^ Breakpoint tick module
+ , bi_tick_index :: !BreakTickIndex -- ^ Breakpoint tick index
+ }
+ deriving (Eq, Ord, Data)
+
+instance Outputable BreakpointId where
+ ppr BreakpointId{bi_tick_mod, bi_tick_index} =
+ text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index
+
+instance NFData BreakpointId where
+ rnf BreakpointId{bi_tick_mod, bi_tick_index} =
+ rnf bi_tick_mod `seq` rnf bi_tick_index
+
+--------------------------------------------------------------------------------
-- | A "counting tick" (where tickishCounts is True) is one that
-- counts evaluations in some way. We cannot discard a counting tick,
=====================================
compiler/GHC/Unit/External.hs
=====================================
@@ -24,7 +24,7 @@ import GHC.Unit.Module.ModIface
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv ( InstEnv, emptyInstEnv )
import GHC.Core.Opt.ConstantFold
-import GHC.Core.Rules ( RuleBase, mkRuleBase)
+import GHC.Core.Rules ( RuleBase, mkRuleBase )
import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv )
import GHC.Types.CompleteMatch
=====================================
compiler/GHC/Unit/Module/ModGuts.hs
=====================================
@@ -7,7 +7,7 @@ where
import GHC.Prelude
-import GHC.ByteCode.Types
+import GHC.HsToCore.Breakpoints
import GHC.ForeignSrcLang
import GHC.Hs
=====================================
compiler/ghc.cabal.in
=====================================
@@ -223,6 +223,7 @@ Library
GHC.Builtin.Uniques
GHC.Builtin.Utils
GHC.ByteCode.Asm
+ GHC.ByteCode.Breakpoints
GHC.ByteCode.InfoTable
GHC.ByteCode.Instr
GHC.ByteCode.Linker
@@ -892,7 +893,6 @@ Library
GHC.Types.Annotations
GHC.Types.Avail
GHC.Types.Basic
- GHC.Types.Breakpoint
GHC.Types.CompleteMatch
GHC.Types.CostCentre
GHC.Types.CostCentre.State
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2578af8a2a622f6e0990e7001ad7ae…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2578af8a2a622f6e0990e7001ad7ae…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
26 Jun '25
Ben Gamari pushed new branch wip/caller-cc-sensitivity at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/caller-cc-sensitivity
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Expose ghc-internal unit id through the settings file
by Marge Bot (＠marge-bot) 26 Jun '25
by Marge Bot (＠marge-bot) 26 Jun '25
26 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
49f44e52 by Teo Camarasu at 2025-06-26T04:19:51-04:00
Expose ghc-internal unit id through the settings file
This in combination with the unit id of the compiler library allows
cabal to know of the two unit ids that should not be reinstalled (in
specific circumstances) as:
- when using plugins, we want to link against exactly the compiler unit
id
- when using TemplateHaskell we want to link against exactly the package
that contains the TemplateHaskell interfaces, which is `ghc-internal`
See: <https://github.com/haskell/cabal/issues/10087>
Resolves #25282
- - - - -
499c4efe by Bryan Richter at 2025-06-26T04:20:33-04:00
CI: Fix and clean up capture of timings
* Fixes the typo that caused 'cat ci-timings' to report "no such file or
directory"
* Gave ci_timings.txt a file extension so it may play better with other
systems
* Fixed the use of time_it so all times are recorded
* Fixed time_it to print name along with timing
- - - - -
86c90c9e by Bryan Richter at 2025-06-26T04:20:33-04:00
CI: Update collapsible section usage
The syntax apparently changed at some point.
- - - - -
04308ee4 by Bryan Richter at 2025-06-26T04:20:33-04:00
CI: Add more collapsible sections
- - - - -
61f2f973 by Teo Camarasu at 2025-06-26T06:55:48-04:00
Implement user-defined allocation limit handlers
Allocation Limits allow killing a thread if they allocate more than a
user-specified limit.
We extend this feature to allow more versatile behaviour.
- We allow not killing the thread if the limit is exceeded.
- We allow setting a custom handler to be called when the limit is exceeded.
User-specified allocation limit handlers run in a fresh thread and are passed
the ThreadId of the thread that exceeded its limit.
We introduce utility functions for getting and setting the allocation
limits of other threads, so that users can reset the limit of a thread
from a handler. Both of these are somewhat coarse-grained as we are
unaware of the allocations in the current nursery chunk.
We provide several examples of usages in testsuite/tests/rts/T22859.hs
Resolves #22859
- - - - -
088cd94e by Florian Ragwitz at 2025-06-26T06:55:58-04:00
Tick uses of wildcard/pun field binds as if using the record selector function
Fixes #17834.
See Note [Record-selector ticks] for additional reasoning behind this as well
as an overview of the implementation details and future improvements.
- - - - -
41 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/common.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/Setup.hs
- docs/users_guide/9.14.1-notes.rst
- hadrian/src/Rules/Generate.hs
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/System/Mem/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/external-symbols.list.in
- rts/include/rts/storage/GC.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- + testsuite/tests/hpc/recsel/Makefile
- + testsuite/tests/hpc/recsel/recsel.hs
- + testsuite/tests/hpc/recsel/recsel.stdout
- + testsuite/tests/hpc/recsel/test.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- + testsuite/tests/rts/T22859.hs
- + testsuite/tests/rts/T22859.stderr
- testsuite/tests/rts/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7591beb672d5726b659ae2c176009…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7591beb672d5726b659ae2c176009…
You're receiving this email because of your account on gitlab.haskell.org.
1
0