Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e28313e3 by sheaf at 2026-09-05T22:07:06-04:00 Preserve tick ordering in 'tickTickedExpr' 'GHC.Core.Utils.tickTickedExpr' tries to combine a tick 't1' into an existing stack of ticks 't2s'. There are two situations: 1. 't1' is subsumed by a tick in 't2s': drop it. 2. A tick in 't2s' is subsumed by 't1', say 't2'. This commit ensures that in case (2) we keep 't1' on the outside instead of replacing 't2' at its position in the stack. This avoids re-ordering source notes (which was the cause of #27749). This fixes a regression introduced in 2dadf3b0d05. Fixes #27749 - - - - - 3172f557 by sheaf at 2026-09-05T22:07:06-04:00 Consistently prefer local source note ticks GHC.Cmm.DebugBlock.cmmDebugGen (DWARF annotations) and GHC.Stg.Debug.quickSourcePos (-finfo-table-map) both contained logic to prioritise source note ticks from the current module. This commit commons up this logic and propagates it to a third consumer: IPE stack frames, in GHC.Driver.GenerateCgIPEStub. See the new function GHC.Types.Tickish.bestSourceNote. - - - - - 10 changed files: - + changelog.d/T27749 - compiler/GHC/Cmm/DebugBlock.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/GenerateCgIPEStub.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/Types/Tickish.hs - + testsuite/tests/simplCore/should_compile/T27749.hs - + testsuite/tests/simplCore/should_compile/T27749.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/T27749 ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27749 +mrs: !16601 +synopsis: + Consistently prefer local source note ticks +description: + When generating IPE stack frames, we now insist on using a source location + that is local to the current module. ===================================== compiler/GHC/Cmm/DebugBlock.hs ===================================== @@ -47,9 +47,8 @@ import GHC.Cmm.Dataflow.Label import Data.Maybe import Data.List ( nubBy ) -import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) +import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE -import Data.Ord ( comparing ) import qualified Data.Map as Map import Data.Foldable ( toList ) import Data.Either ( partitionEithers ) @@ -152,10 +151,6 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes -- from the same source file. Furthermore, dumps take priority -- (if we generated one, we probably want debug information to -- refer to it). - bestSrcTick = minimumBy (comparing rangeRating) - rangeRating (span, _) - | srcSpanFile span == thisFile = 1 - | otherwise = 2 :: Int thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc -- Returns block tree for this scope as well as all nested @@ -189,17 +184,14 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes blocks | top = seqList childs childs | otherwise = [] - -- A source tick scopes over all nested blocks. However - -- their source ticks might take priority. - isSourceTick (SourceNote span a) = Just (span, a) - isSourceTick _ = Nothing -- Collect ticks from all blocks inside the tick scope. -- We attempt to filter out duplicates while we're at it. ticks = nubBy (flip tickishContains) $ bCtxsTicks bctxs ++ ticksToCopy scope - stick = case nonEmpty $ mapMaybe isSourceTick ticks of - Nothing -> cstick - Just sticks -> Just $! bestSrcTick (sticks `NE.appendList` maybeToList cstick) + -- A source tick scopes over all nested blocks. However + -- their source ticks might take priority. + !stick = bestSourceNote True thisFile $ + ticks ++ map (uncurry SourceNote) (maybeToList cstick) -- | Build a map of blocks sorted by their tick scopes -- ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -426,8 +426,10 @@ tickTickedExpr preserve_anf t1 t2s e -- combination. -- See Note [Avoiding duplicate ticks] in GHC.Core.Opt.FloatOut -- and Note [Ordering of source notes] in GHC.Types.Tickish. - | Just t2s' <- combine_into_stack t2s - = apply_ticks t2s' e + | Just combined <- combine_into_stack t1 (NE.toList t2s) + = case combined of + DropIncomingTick -> apply_ticks t2s e + TickOutsideStack t1' t2s' -> Tick t1' (apply_ticks t2s' e) -- Case 2: 't1' can be commuted past all the ticks in the stack, e.g. because -- it has tighter placement properties than all the ticks in the stack. @@ -437,22 +439,48 @@ tickTickedExpr preserve_anf t1 t2s e -- Fallback: keep the new tick on the outside. | otherwise - = apply_ticks (t1 NE.:| NE.toList t2s) e + = Tick t1 (apply_ticks t2s e) where - apply_ticks :: NE.NonEmpty CoreTickish -> CoreExpr -> CoreExpr + apply_ticks :: Foldable f => f CoreTickish -> CoreExpr -> CoreExpr apply_ticks ts e' = foldr Tick e' ts + {-# INLINE apply_ticks #-} - -- Try to combine 't1' into a stack of ticks. - combine_into_stack :: NE.NonEmpty CoreTickish -> Maybe (NE.NonEmpty CoreTickish) - combine_into_stack (t2 NE.:| rest) - | Just t2' <- combineTickish_maybe t1 t2 - = Just (t2' NE.:| rest) - | r_hd : r_tl <- rest - , Just rest' <- combine_into_stack (r_hd NE.:| r_tl) - = Just (t2 NE.:| NE.toList rest') +-- | The result of combining a tick into a stack of ticks. +data CombineIntoStack + -- | Drop the incoming tick: it's subsumed by a tick in the stack. + = DropIncomingTick + -- | Keep the incoming tick on the outside (possibly merged with an inner tick), + -- and wrap it around the given stack (from which we removed subsumed ticks). + | TickOutsideStack !CoreTickish [CoreTickish] + +-- | Try to combine a tick into a stack of ticks, never re-ordering any ticks. +-- +-- - If the tick is subsumed by a tick in the stack, drop it. +-- - Otherwise merge it with the ticks it subsumes and keep the result outside +-- the whole stack (#27749), discarding the ticks it makes redundant. +combine_into_stack :: CoreTickish -> [CoreTickish] -> Maybe CombineIntoStack +combine_into_stack _ [] = Nothing +combine_into_stack s (t : ts) = + case combineTickish_maybe s t of + Just s1 + -- 's1 is redundant: drop it, keeping the stack as it is. + | s1 == t -> Just DropIncomingTick + -- 't' is redundant: put 's1' outside the stack. + -- Carry on, as 's1' may subsume further ticks in the stack. + | otherwise -> Just $ combine_into_stack s1 ts `orElse` TickOutsideStack s1 ts + -- Didn't combine: recur, and discard 't' if we end up putting a tick on the + -- outside that subsumes it. + Nothing -> retain t <$> combine_into_stack s ts + where + retain _ DropIncomingTick = DropIncomingTick -- retains it + retain t1 res@(TickOutsideStack s1 ss) + | Just t1' <- combineTickish_maybe s1 t1 + , s1 == t1' + -- s1 subsumes t1: drop t1 + = res | otherwise - = Nothing + = TickOutsideStack s1 (t1 : ss) {- Note [Pushing SCCs inwards] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Driver/GenerateCgIPEStub.hs ===================================== @@ -28,7 +28,8 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.CgUtils (CgStream) import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) import GHC.Types.Name.Set (NonCaffySet) -import GHC.Types.Tickish (GenTickish (SourceNote)) +import GHC.Data.FastString (FastString) +import GHC.Types.Tickish (bestSourceNote) import GHC.Unit.Types (Module, moduleName) import GHC.Unit.Module (moduleNameString) import qualified GHC.Utils.Logger as Logger @@ -257,11 +258,12 @@ generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesW -- performance suffered considerably as a result (see #23103). lookupEstimatedTicks :: HscEnv + -> FastString -- ^ the source file of the module being compiled -> Map CmmInfoTable (Maybe IpeSourceLocation) -> IPEStats -> CmmGroupSRTs -> IO (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) -lookupEstimatedTicks hsc_env ipes stats cmm_group_srts = +lookupEstimatedTicks hsc_env this_file ipes stats cmm_group_srts = -- Pass 2: Create an entry in the IPE map for every info table listed in -- this CmmGroupSRTs. If the info table is a stack info table and -- -finfo-table-map-with-stack is enabled, look up its estimated source @@ -286,9 +288,9 @@ lookupEstimatedTicks hsc_env ipes stats cmm_group_srts = labelsToSources :: Map CLabel IpeSourceLocation labelsToSources = if platformTablesNextToCode platform then - foldl' labelsToSourcesWithTNTC Map.empty cmm_group_srts + foldl' (labelsToSourcesWithTNTC this_file) Map.empty cmm_group_srts else - foldl' labelsToSourcesSansTNTC Map.empty cmm_group_srts + foldl' (labelsToSourcesSansTNTC this_file) Map.empty cmm_group_srts collectInfoTables :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) @@ -331,15 +333,16 @@ lookupEstimatedTicks hsc_env ipes stats cmm_group_srts = -- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] labelsToSourcesWithTNTC - :: Map CLabel IpeSourceLocation + :: FastString -- ^ the source file of the module being compiled + -> Map CLabel IpeSourceLocation -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Map CLabel IpeSourceLocation -labelsToSourcesWithTNTC acc (CmmProc _ _ _ cmm_graph) = +labelsToSourcesWithTNTC this_file acc (CmmProc _ _ _ cmm_graph) = foldl' go acc (toBlockList cmm_graph) where go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation go acc block = - case (,) <$> returnFrameLabel <*> lastTickInBlock of + case (,) <$> returnFrameLabel <*> nearestTickInBlock of Just (clabel, src_loc) -> Map.insert clabel src_loc acc Nothing -> acc where @@ -351,20 +354,20 @@ labelsToSourcesWithTNTC acc (CmmProc _ _ _ cmm_graph) = (CmmCall _ (Just l) _ _ _ _) -> Just $ mkAsmTempLabel l _ -> Nothing - lastTickInBlock = foldr maybeTick Nothing (blockToList middleBlock) - - maybeTick :: CmmNode O O -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation - maybeTick _ s@(Just _) = s - maybeTick (CmmTick (SourceNote span name)) Nothing = Just (span, name) - maybeTick _ _ = Nothing -labelsToSourcesWithTNTC acc _ = acc + -- The ticks enclosing the call, innermost first. + -- NB: the innermost tick may not be from the current module, due to inlining. + nearestTickInBlock = + bestSourceNote False this_file + [ t | CmmTick t <- reverse (blockToList middleBlock) ] +labelsToSourcesWithTNTC _ acc _ = acc -- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] labelsToSourcesSansTNTC - :: Map CLabel IpeSourceLocation + :: FastString -- ^ the source file of the module being compiled + -> Map CLabel IpeSourceLocation -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Map CLabel IpeSourceLocation -labelsToSourcesSansTNTC acc (CmmProc _ _ _ cmm_graph) = +labelsToSourcesSansTNTC this_file acc (CmmProc _ _ _ cmm_graph) = foldl' go acc (toBlockList cmm_graph) where go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation @@ -380,7 +383,9 @@ labelsToSourcesSansTNTC acc (CmmProc _ _ _ cmm_graph) = case (b, lastTick) of (CmmStore _ (CmmLit (CmmLabel l)) _, Just src_loc) -> (Map.insert l src_loc acc, Nothing) - (CmmTick (SourceNote span name), _) -> - (acc, Just (span, name)) + (CmmTick t, _) + -- Pick the innermost source note tick from the current file. + | Just src_loc <- bestSourceNote False this_file [t] -> + (acc, Just src_loc) _ -> (acc, lastTick) -labelsToSourcesSansTNTC acc _ = acc +labelsToSourcesSansTNTC _ acc _ = acc ===================================== compiler/GHC/Driver/Main/Compile.hs ===================================== @@ -699,7 +699,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do Just _ -> do cmms <- {-# SCC "StgToCmm" #-} - doCodeGen hsc_env this_mod denv tycons + doCodeGen hsc_env this_mod mod_loc denv tycons cost_centre_info stg_binds @@ -957,14 +957,14 @@ This reduces residency towards the end of the CodeGen phase significantly (5-10%). -} -doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon] +doCodeGen :: HscEnv -> Module -> ModLocation -> InfoTableProvMap -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs -> IO (CgStream CmmGroupSRTs CmmCgInfos) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost. -doCodeGen hsc_env this_mod denv tycons +doCodeGen hsc_env this_mod mod_loc denv tycons cost_centre_info stg_binds_w_fvs = do let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env @@ -972,6 +972,7 @@ doCodeGen hsc_env this_mod denv tycons tmpfs = hsc_tmpfs hsc_env platform = targetPlatform dflags stg_ppr_opts = (initStgPprOpts dflags) + this_file = maybe nilFS mkFastString $ ml_hs_file mod_loc putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs) @@ -1033,7 +1034,7 @@ doCodeGen hsc_env this_mod denv tycons -- Positions] in GHC.Stg.Debug. (ipes', stats') <- if (gopt Opt_InfoTableMap dflags) then - liftIO $ lookupEstimatedTicks hsc_env ipes stats cmm_srts + liftIO $ lookupEstimatedTicks hsc_env this_file ipes stats cmm_srts else return (ipes, stats) ===================================== compiler/GHC/Stg/Debug.hs ===================================== @@ -135,10 +135,12 @@ collectAlt alt = do e' <- collectExpr $ alt_rhs alt -- propagated downwards by 'withSpan'. It's "quick" because it works only using immediate context rather -- than looking at the parent context like 'withSpan' quickSourcePos :: FastString -> StgExpr -> Maybe SpanWithLabel -quickSourcePos cur_mod (StgTick (SourceNote ss m) e) - | srcSpanFile ss == cur_mod = Just (SpanWithLabel ss m) - | otherwise = quickSourcePos cur_mod e -quickSourcePos _ _ = Nothing +quickSourcePos cur_mod e + = uncurry SpanWithLabel <$> bestSourceNote False cur_mod (head_ticks e) + where + -- The ticks at the head of the expression, outermost first. + head_ticks (StgTick t e') = t : head_ticks e' + head_ticks _ = [] recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M () recordStgIdPosition id best_span ss = do ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -18,6 +18,7 @@ module GHC.Types.Tickish ( tickishContains, combineTickish_maybe, tickishCommutable, + bestSourceNote, -- * Breakpoint tick identifiers BreakpointId(..), BreakTickIndex @@ -32,7 +33,7 @@ import GHC.Core.Type import GHC.Unit.Module import GHC.Types.CostCentre -import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) +import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan, srcSpanFile ) import GHC.Types.Var import GHC.Utils.Panic @@ -40,6 +41,8 @@ import GHC.Utils.Panic import Language.Haskell.Syntax.Extension ( NoExtField ) import Data.Data +import Data.List ( partition ) +import Data.Maybe ( listToMaybe, mapMaybe ) import GHC.Utils.Binary import GHC.Utils.Outputable (Outputable (ppr), text, (<+>)) @@ -645,3 +648,25 @@ tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) -- compare the String last tickishContains t1 t2 = t1 == t2 + +-- | Choose the "best" source note in the given candidate list of ticks, +-- preferring source notes that are local to the source file being consdiered. +bestSourceNote + :: Bool + -- ^ accept a location in another module if there are none in the + -- current module? + -> FastString -- ^ the "local" source file + -> [GenTickish pass] -- ^ candidates (best first) + -> Maybe (RealSrcSpan, LexicalFastString) +bestSourceNote accept_outside_loc this_file ticks + = listToMaybe $ + if accept_outside_loc + then here ++ elsewhere + else here + where + (here, elsewhere) + = partition ((this_file ==) . srcSpanFile . fst) + $ mapMaybe source_location ticks + + source_location (SourceNote span name) = Just (span, name) + source_location _ = Nothing ===================================== testsuite/tests/simplCore/should_compile/T27749.hs ===================================== @@ -0,0 +1,9 @@ +module T27749 where + +select :: Maybe Int -> (Int -> Int) -> Int +select m k = case m of { Nothing -> 0; Just x -> k x } +{-# INLINE select #-} + +ordering :: Maybe Int -> Int -> Int +ordering m b = select m (\x -> x + b) +{-# OPAQUE ordering #-} ===================================== testsuite/tests/simplCore/should_compile/T27749.stderr ===================================== @@ -0,0 +1,4 @@ +ordering + = \ (m :: Maybe Int) (b :: Int) -> + src<T27749.hs:8:1-37> + src<T27749.hs:4:1-54> ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -612,3 +612,9 @@ test('T27296b', [], makefile_test, ['T27296b']) test('T27589', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) test('T27590', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) test('T27556', [only_ways('ghci'), extra_hc_opts('-O -fno-unoptimized-core-for-interpreter')], ghci_script, ['T27556.script']) + +# Check the stack of source notes at the top of the body of 'ordering' +# is in the correct order. +test('T27749', + multiline_grep_errmsg(r'ordering\n.*\n(\s+src<[^>]*>\n)+'), + compile, ['-O -g3 -ddump-simpl -dsuppress-uniques']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a6061455d54e68ad2f45ff112fbd01b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a6061455d54e68ad2f45ff112fbd01b... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help