[Git][ghc/ghc] Pushed new branch wip/apk/remove-quickest
by Andreas Klebinger (＠AndreasK) 25 Aug '26
by Andreas Klebinger (＠AndreasK) 25 Aug '26
25 Aug '26
Andreas Klebinger pushed new branch wip/apk/remove-quickest at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/apk/remove-quickest
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
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 25 Aug '26
by Marge Bot (＠marge-bot) 25 Aug '26
25 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
fbaac93d by Andreas Klebinger at 2026-08-25T10:15:41-04:00
rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
We accidentally operated over `uint64_t*` when we should use `uint8_t`.
Fixes #27569
- - - - -
b8729895 by Zubin Duggal at 2026-08-25T10:15:43-04:00
ghc-internal: annotateSTM should use catchSTM# rather than catch#
A catch# frame inside a transaction breaks retry and async exception
delivery.
Fixes #27657
- - - - -
dddcdee3 by Alan Zimmerman at 2026-08-25T10:15:43-04:00
EPA: Uses Parsers.parseModule for exactprint tests
Parsers.parseModule is the advertised way to parse for use for exact
printing in the ghc-exactprint library. This commit updates the GHC
exact print testing to use it.
This requires moving the comment balancing that was occurring
only in the test path into the advertising parser path, so it moves
from Transforms.hs to Utils.hs.
Also update the comment adding to honour trailing annotations
- - - - -
13 changed files:
- + changelog.d/T27657
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- rts/linker/elf_reloc_riscv64.c
- + testsuite/tests/concurrent/should_run/T27657a.hs
- + testsuite/tests/concurrent/should_run/T27657a.stdout
- + testsuite/tests/concurrent/should_run/T27657b.hs
- + testsuite/tests/concurrent/should_run/T27657b.stdout
- testsuite/tests/concurrent/should_run/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
changelog.d/T27657
=====================================
@@ -0,0 +1,9 @@
+section: base
+issues: #27657
+mrs: !16508
+synopsis:
+ Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
+description:
+ ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
+ ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
+ correct way to catch exceptions inside STM.
=====================================
libraries/ghc-internal/src/GHC/Internal/STM.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation)
import GHC.Internal.Exception.Type (WhileHandling(..))
import GHC.Internal.Maybe (Maybe(..))
import GHC.Internal.Prim (
- RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
+ RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
)
import GHC.Internal.Prim.PtrEq (sameTVar#)
@@ -213,7 +213,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
-- | Execute an 'STM' action, adding the given 'ExceptionContext'
-- to any thrown synchronous exceptions.
annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
-annotateSTM ann (STM io) = STM (catch# io handler)
+annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657
where
handler se = raiseIO# (addExceptionContext ann se)
=====================================
rts/linker/elf_reloc_riscv64.c
=====================================
@@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) {
/* The main object code */
void *codeBegin = oc->image + oc->misalignment;
- __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize));
+ __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize));
/* Jump Islands */
__builtin___clear_cache((void *)oc->symbol_extras,
=====================================
testsuite/tests/concurrent/should_run/T27657a.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO
+-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper.
+
+import Control.Exception
+import GHC.Conc
+
+main :: IO ()
+main = do
+ r <- atomically $
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) -> retry)
+ `orElse` pure "T27657a: completed"
+ putStrLn r
=====================================
testsuite/tests/concurrent/should_run/T27657a.stdout
=====================================
@@ -0,0 +1 @@
+T27657a: completed
=====================================
testsuite/tests/concurrent/should_run/T27657b.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- An async exception delivered while a catchSTM handler runs must abort the
+-- transaction, not be swallowed by a restart of the invalidated one.
+
+import Control.Concurrent.MVar
+import Control.Exception
+import GHC.Conc
+
+waitParked :: ThreadId -> IO ()
+waitParked t = do
+ s <- threadStatus t
+ case s of
+ ThreadBlocked BlockedOnMVar -> pure ()
+ _ -> threadDelay 1000 >> waitParked t
+
+main :: IO ()
+main = do
+ tv <- newTVarIO (0 :: Int)
+ park <- newEmptyMVar
+ result <- newEmptyMVar
+ t <- forkIO $ do
+ r <- try $ atomically $ do
+ v <- readTVar tv
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) ->
+ if v == 0
+ then do unsafeIOToSTM (takeMVar park)
+ pure "handler resumed"
+ else pure "transaction restarted, exception dropped")
+ putMVar result (r :: Either SomeException String)
+ -- parked in the handler, so t cannot revalidate its trec before delivery
+ waitParked t
+ atomically (writeTVar tv 1)
+ killThread t
+ r <- takeMVar result
+ putStrLn $ case r of
+ Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered"
+ | otherwise -> "T27657b: unexpected exception: " ++ displayException e
+ Right s -> "T27657b: FAILED, " ++ s
=====================================
testsuite/tests/concurrent/should_run/T27657b.stdout
=====================================
@@ -0,0 +1 @@
+T27657b: killThread delivered
=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -340,3 +340,6 @@ test('T27105_fail',
extra_run_opts('+RTS -C0.2 -RTS'), expect_fail,
run_timeout_multiplier(0.05)],
multimod_compile_and_run, ['T27105.hs', ''])
+
+test('T27657a', normal, compile_and_run, [''])
+test('T27657b', normal, compile_and_run, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where
Just exps -> do
let (op,cp,tcs) = am_exports $ anns an0
op' <- markEpToken op
- exps' <- mapM markAnnotated exps
+ exps' <- mapM markAnnotated (filter notIEDoc exps)
tcs' <- mapM markEpToken tcs
cp' <- markEpToken cp
return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}})
=====================================
utils/check-exact/Main.hs
=====================================
@@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Test17519.hs" Nothing
-- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing
-- "../../testsuite/tests/printer/Test19798.hs" Nothing
- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ -- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ "../../testsuite/tests/printer/Haddock1.hs" Nothing
-- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing
-- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing
@@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8
testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO ()
testOneFile _ libdir fileName mchanger = do
- (p,_toks) <- parseOneFile libdir fileName
+ p <- parseOneFile libdir fileName
let
origAst = ppAst p
pped = exactPrint p
@@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do
changedSource <- readFile newFile
return (expectedSource == changedSource, expectedSource, changedSource)
- (p',_) <- parseOneFile libdir newFile
+ p' <- parseOneFile libdir newFile
let newAstStr :: String
newAstStr = ppAst p'
writeBinFile newAstFile newAstStr
@@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do
ppAst :: Data a => a -> String
ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast
-
-parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token])
+parseOneFile :: FilePath -> FilePath -> IO ParsedSource
parseOneFile libdir fileName = do
- res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName
+ res <- Parsers.parseModule libdir fileName
case res of
Left m -> error (internalDebugShowMessages m)
- Right (injectedComments, _dflags, pmod) -> do
- let !pmodWithComments = insertCppComments pmod injectedComments
- return (pmodWithComments, [])
+ Right pmod -> return pmod
-- ---------------------------------------------------------------------
@@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do
- let (oldDecls) = map unWrapValBind bs
- -- let decls = s:d:oldDecls
+ let oldDecls = map unWrapValBind bs
let oldDecls' = captureLineSpacing oldDecls
let (VbSig o:oldBinds) = map wrapValBind oldDecls'
o' = setEntryDP o (DifferentLine 2 0)
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -46,6 +46,7 @@ module Parsers (
) where
import Preprocess
+import Utils
import Data.Functor (void)
@@ -270,7 +271,10 @@ postParseTransform
-> Either a (GHC.ParsedSource)
postParseTransform parseRes = fmap mkAnns parseRes
where
- mkAnns (_cs, _, m) = fixModuleComments m
+ mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs)
+ noIEDoc (GHC.L l m) = case GHC.hsmodExports m of
+ Nothing -> GHC.L l m
+ Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps }
fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource
fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail
import GHC hiding (parseModule, parsedSource)
import GHC.Parser.PostProcess ( wrapValBind )
import GHC.Data.FastString
-import GHC.Types.SrcLoc
import Data.Data
import Data.List (unsnoc)
@@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r)
(a',b') = balanceComments a b
r = balanceCommentsList' (b':ls)
+balanceCommentsListA :: [LocatedA a ] -> [LocatedA a]
+balanceCommentsListA [] = []
+balanceCommentsListA [x] = [x]
+balanceCommentsListA (a:b:ls) = (a':r)
+ where
+ (a',b') = balanceCommentsA a b
+ r = balanceCommentsListA (b':ls)
+
-- |The GHC parser puts all comments appearing between the end of one AST
-- item and the beginning of the next as 'annPriorComments' for the second one.
-- This function takes two adjacent AST items and moves any 'annPriorComments'
@@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt)
(HsValBinds _ vb') -> vb'
_ -> ValBinds noExtField []
-
-balanceCommentsListA :: [LocatedA a] -> [LocatedA a]
-balanceCommentsListA [] = []
-balanceCommentsListA [x] = [x]
-balanceCommentsListA (a:b:ls) = (a':r)
- where
- (a',b') = balanceCommentsA a b
- r = balanceCommentsListA (b':ls)
-
-- |Prior to moving an AST element, make sure any trailing comments belonging to
-- it are attached to it, and not the following element. Of necessity this is a
-- heuristic process, to be tuned later. Possibly a variant should be provided
@@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs)
-- ---------------------------------------------------------------------
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
-splitComments p cs = (before, middle, after)
- where
- cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmpe (L _ _) = True
-
- cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
- cmpb (L _ _) = True
-
- (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
- (before, middle) = break cmpb beforeEnd
-
-
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsEnd p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
--- | Split comments into ones occurring before the start of the reference
--- span, and those after it.
-splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsStart p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u)
=> LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u)
moveLeadingComments (L la a) lb = (L la' a, lb')
@@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs)
anchorFromLocatedA :: LocatedA a -> RealSrcSpan
anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc
--- | Get the full span of interest for comments from a LocatedA.
--- This extends up to the last TrailingAnn
-fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
-fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr
- where
- r = epaLocationRealSrcSpan anc
- trailing_loc ta = case ta_location ta of
- EpaSpan (RealSrcSpan s _) -> [s]
- _ -> []
- rr = case reverse (concatMap trailing_loc tas) of
- [] -> r
- (s:_) -> combineRealSrcSpans r s
-
-- ---------------------------------------------------------------------
balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs))
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
(p2, remaining) = insertTopLevelCppComments p1 toplevel
addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
- addCommentsListItem = addComments
+ addCommentsListItem = addCommentsA
addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList)
addCommentsList = addComments
@@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
_ -> return $ EpAnn anc an ocs
+ addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
+ addCommentsA ann@(EpAnn anc an ocs) = do
+ case anc of
+ EpaSpan (RealSrcSpan s _) -> do
+ unAllocated <- get
+ let
+ (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated
+ balanced = splitCommentsEnd s (EpaComments these)
+ cs' = sortEpAnnComments (ocs <> balanced)
+ put rest
+ return $ EpAnn anc an cs'
+
+ _ -> return $ EpAnn anc an ocs
+
workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
workInComments ocs [] = ocs
workInComments ocs new = cs'
@@ -264,9 +278,14 @@ workInComments ocs new = cs'
= break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) )
new
+sortEpAnnComments :: EpAnnComments -> EpAnnComments
+sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs)
+sortEpAnnComments (EpaCommentsBalanced pc fc)
+ = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc)
+
insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment])
insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs
- = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3)
+ = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3)
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs))
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs))
where
@@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
cs' = workInComments (comments an1) stay
_ -> (an1,cs0a)
- (mexports', an3, cs1) =
- case mexports of
- Nothing -> (Nothing, an2, cs0b)
- Just exports -> (Just exports', an3', cse)
- where
- (csh', cs0b') = case am_exports $ anns an2 of
- (tokOP, _tokCP, _tokCommas) ->
- case tokOP of
- (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n)
- where
- (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) )
- cs0b
-
- _ -> ([], cs0b)
- hc1' = workInComments (comments an2) csh'
- an3' = an2 { comments = hc1' }
- (exports', cse) = allocPreceding exports cs0b'
- (imports0, cs2) = allocPreceding imports cs1
+ (imports0, cs2) = allocPreceding imports cs0b
(imports', hc0i) = balanceFirstLocatedAComments imports0
(decls0, cs3) = allocPreceding decls cs2
@@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
-- Either hc0i or hc0d should have comments. Combine them
hc0 = hc0i ++ hc0d
- (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0
- hc2 = workInComments (comments an3) hc1
- an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 }
+ (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0
+ hc2 = workInComments (comments an2) hc1
+ an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 }
allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment])
allocPreceding [] cs' = ([], cs')
@@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c)
annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c)
annListBracketsLocs ListNone = (noAnn, noAnn)
-
data SplitWhere = Before | After
splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment])
@@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p'
-- ---------------------------------------------------------------------
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
+fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann
+
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan
+fullSpanFromEpAnnA (EpAnn anc tas _) = rr
+ where
+ r = epaLocationRealSrcSpan anc
+ trailing_loc ta = case ta_location ta of
+ EpaSpan (RealSrcSpan s _) -> [s]
+ _ -> []
+ rr = case reverse (concatMap trailing_loc tas) of
+ [] -> r
+ (s:_) -> combineRealSrcSpans r s
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
+splitComments p cs = (before, middle, after)
+ where
+ cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmpe (L _ _) = True
+
+ cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
+ cmpb (L _ _) = True
+
+ (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
+ (before, middle) = break cmpb beforeEnd
+
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsEnd p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- | Split comments into ones occurring before the start of the reference
+-- span, and those after it.
+splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsStart p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- ---------------------------------------------------------------------
+
ghcCommentText :: LEpaComment -> String
ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s
ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e885a4e595f03aa11669eef7e4520c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e885a4e595f03aa11669eef7e4520c…
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
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 25 Aug '26
by Marge Bot (＠marge-bot) 25 Aug '26
25 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
0289475d by Andreas Klebinger at 2026-08-25T10:24:01-04:00
rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
We accidentally operated over `uint64_t*` when we should use `uint8_t`.
Fixes #27569
- - - - -
232ed2c1 by Zubin Duggal at 2026-08-25T10:24:03-04:00
ghc-internal: annotateSTM should use catchSTM# rather than catch#
A catch# frame inside a transaction breaks retry and async exception
delivery.
Fixes #27657
- - - - -
1b3be33c by Alan Zimmerman at 2026-08-25T10:24:04-04:00
EPA: Uses Parsers.parseModule for exactprint tests
Parsers.parseModule is the advertised way to parse for use for exact
printing in the ghc-exactprint library. This commit updates the GHC
exact print testing to use it.
This requires moving the comment balancing that was occurring
only in the test path into the advertising parser path, so it moves
from Transforms.hs to Utils.hs.
Also update the comment adding to honour trailing annotations
- - - - -
13 changed files:
- + changelog.d/T27657
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- rts/linker/elf_reloc_riscv64.c
- + testsuite/tests/concurrent/should_run/T27657a.hs
- + testsuite/tests/concurrent/should_run/T27657a.stdout
- + testsuite/tests/concurrent/should_run/T27657b.hs
- + testsuite/tests/concurrent/should_run/T27657b.stdout
- testsuite/tests/concurrent/should_run/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
changelog.d/T27657
=====================================
@@ -0,0 +1,9 @@
+section: base
+issues: #27657
+mrs: !16508
+synopsis:
+ Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
+description:
+ ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
+ ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
+ correct way to catch exceptions inside STM.
=====================================
libraries/ghc-internal/src/GHC/Internal/STM.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation)
import GHC.Internal.Exception.Type (WhileHandling(..))
import GHC.Internal.Maybe (Maybe(..))
import GHC.Internal.Prim (
- RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
+ RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
)
import GHC.Internal.Prim.PtrEq (sameTVar#)
@@ -213,7 +213,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
-- | Execute an 'STM' action, adding the given 'ExceptionContext'
-- to any thrown synchronous exceptions.
annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
-annotateSTM ann (STM io) = STM (catch# io handler)
+annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657
where
handler se = raiseIO# (addExceptionContext ann se)
=====================================
rts/linker/elf_reloc_riscv64.c
=====================================
@@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) {
/* The main object code */
void *codeBegin = oc->image + oc->misalignment;
- __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize));
+ __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize));
/* Jump Islands */
__builtin___clear_cache((void *)oc->symbol_extras,
=====================================
testsuite/tests/concurrent/should_run/T27657a.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO
+-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper.
+
+import Control.Exception
+import GHC.Conc
+
+main :: IO ()
+main = do
+ r <- atomically $
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) -> retry)
+ `orElse` pure "T27657a: completed"
+ putStrLn r
=====================================
testsuite/tests/concurrent/should_run/T27657a.stdout
=====================================
@@ -0,0 +1 @@
+T27657a: completed
=====================================
testsuite/tests/concurrent/should_run/T27657b.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- An async exception delivered while a catchSTM handler runs must abort the
+-- transaction, not be swallowed by a restart of the invalidated one.
+
+import Control.Concurrent.MVar
+import Control.Exception
+import GHC.Conc
+
+waitParked :: ThreadId -> IO ()
+waitParked t = do
+ s <- threadStatus t
+ case s of
+ ThreadBlocked BlockedOnMVar -> pure ()
+ _ -> threadDelay 1000 >> waitParked t
+
+main :: IO ()
+main = do
+ tv <- newTVarIO (0 :: Int)
+ park <- newEmptyMVar
+ result <- newEmptyMVar
+ t <- forkIO $ do
+ r <- try $ atomically $ do
+ v <- readTVar tv
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) ->
+ if v == 0
+ then do unsafeIOToSTM (takeMVar park)
+ pure "handler resumed"
+ else pure "transaction restarted, exception dropped")
+ putMVar result (r :: Either SomeException String)
+ -- parked in the handler, so t cannot revalidate its trec before delivery
+ waitParked t
+ atomically (writeTVar tv 1)
+ killThread t
+ r <- takeMVar result
+ putStrLn $ case r of
+ Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered"
+ | otherwise -> "T27657b: unexpected exception: " ++ displayException e
+ Right s -> "T27657b: FAILED, " ++ s
=====================================
testsuite/tests/concurrent/should_run/T27657b.stdout
=====================================
@@ -0,0 +1 @@
+T27657b: killThread delivered
=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -340,3 +340,6 @@ test('T27105_fail',
extra_run_opts('+RTS -C0.2 -RTS'), expect_fail,
run_timeout_multiplier(0.05)],
multimod_compile_and_run, ['T27105.hs', ''])
+
+test('T27657a', normal, compile_and_run, [''])
+test('T27657b', normal, compile_and_run, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where
Just exps -> do
let (op,cp,tcs) = am_exports $ anns an0
op' <- markEpToken op
- exps' <- mapM markAnnotated exps
+ exps' <- mapM markAnnotated (filter notIEDoc exps)
tcs' <- mapM markEpToken tcs
cp' <- markEpToken cp
return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}})
=====================================
utils/check-exact/Main.hs
=====================================
@@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Test17519.hs" Nothing
-- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing
-- "../../testsuite/tests/printer/Test19798.hs" Nothing
- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ -- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ "../../testsuite/tests/printer/Haddock1.hs" Nothing
-- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing
-- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing
@@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8
testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO ()
testOneFile _ libdir fileName mchanger = do
- (p,_toks) <- parseOneFile libdir fileName
+ p <- parseOneFile libdir fileName
let
origAst = ppAst p
pped = exactPrint p
@@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do
changedSource <- readFile newFile
return (expectedSource == changedSource, expectedSource, changedSource)
- (p',_) <- parseOneFile libdir newFile
+ p' <- parseOneFile libdir newFile
let newAstStr :: String
newAstStr = ppAst p'
writeBinFile newAstFile newAstStr
@@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do
ppAst :: Data a => a -> String
ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast
-
-parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token])
+parseOneFile :: FilePath -> FilePath -> IO ParsedSource
parseOneFile libdir fileName = do
- res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName
+ res <- Parsers.parseModule libdir fileName
case res of
Left m -> error (internalDebugShowMessages m)
- Right (injectedComments, _dflags, pmod) -> do
- let !pmodWithComments = insertCppComments pmod injectedComments
- return (pmodWithComments, [])
+ Right pmod -> return pmod
-- ---------------------------------------------------------------------
@@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do
- let (oldDecls) = map unWrapValBind bs
- -- let decls = s:d:oldDecls
+ let oldDecls = map unWrapValBind bs
let oldDecls' = captureLineSpacing oldDecls
let (VbSig o:oldBinds) = map wrapValBind oldDecls'
o' = setEntryDP o (DifferentLine 2 0)
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -46,6 +46,7 @@ module Parsers (
) where
import Preprocess
+import Utils
import Data.Functor (void)
@@ -270,7 +271,10 @@ postParseTransform
-> Either a (GHC.ParsedSource)
postParseTransform parseRes = fmap mkAnns parseRes
where
- mkAnns (_cs, _, m) = fixModuleComments m
+ mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs)
+ noIEDoc (GHC.L l m) = case GHC.hsmodExports m of
+ Nothing -> GHC.L l m
+ Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps }
fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource
fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail
import GHC hiding (parseModule, parsedSource)
import GHC.Parser.PostProcess ( wrapValBind )
import GHC.Data.FastString
-import GHC.Types.SrcLoc
import Data.Data
import Data.List (unsnoc)
@@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r)
(a',b') = balanceComments a b
r = balanceCommentsList' (b':ls)
+balanceCommentsListA :: [LocatedA a ] -> [LocatedA a]
+balanceCommentsListA [] = []
+balanceCommentsListA [x] = [x]
+balanceCommentsListA (a:b:ls) = (a':r)
+ where
+ (a',b') = balanceCommentsA a b
+ r = balanceCommentsListA (b':ls)
+
-- |The GHC parser puts all comments appearing between the end of one AST
-- item and the beginning of the next as 'annPriorComments' for the second one.
-- This function takes two adjacent AST items and moves any 'annPriorComments'
@@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt)
(HsValBinds _ vb') -> vb'
_ -> ValBinds noExtField []
-
-balanceCommentsListA :: [LocatedA a] -> [LocatedA a]
-balanceCommentsListA [] = []
-balanceCommentsListA [x] = [x]
-balanceCommentsListA (a:b:ls) = (a':r)
- where
- (a',b') = balanceCommentsA a b
- r = balanceCommentsListA (b':ls)
-
-- |Prior to moving an AST element, make sure any trailing comments belonging to
-- it are attached to it, and not the following element. Of necessity this is a
-- heuristic process, to be tuned later. Possibly a variant should be provided
@@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs)
-- ---------------------------------------------------------------------
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
-splitComments p cs = (before, middle, after)
- where
- cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmpe (L _ _) = True
-
- cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
- cmpb (L _ _) = True
-
- (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
- (before, middle) = break cmpb beforeEnd
-
-
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsEnd p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
--- | Split comments into ones occurring before the start of the reference
--- span, and those after it.
-splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsStart p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u)
=> LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u)
moveLeadingComments (L la a) lb = (L la' a, lb')
@@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs)
anchorFromLocatedA :: LocatedA a -> RealSrcSpan
anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc
--- | Get the full span of interest for comments from a LocatedA.
--- This extends up to the last TrailingAnn
-fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
-fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr
- where
- r = epaLocationRealSrcSpan anc
- trailing_loc ta = case ta_location ta of
- EpaSpan (RealSrcSpan s _) -> [s]
- _ -> []
- rr = case reverse (concatMap trailing_loc tas) of
- [] -> r
- (s:_) -> combineRealSrcSpans r s
-
-- ---------------------------------------------------------------------
balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs))
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
(p2, remaining) = insertTopLevelCppComments p1 toplevel
addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
- addCommentsListItem = addComments
+ addCommentsListItem = addCommentsA
addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList)
addCommentsList = addComments
@@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
_ -> return $ EpAnn anc an ocs
+ addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
+ addCommentsA ann@(EpAnn anc an ocs) = do
+ case anc of
+ EpaSpan (RealSrcSpan s _) -> do
+ unAllocated <- get
+ let
+ (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated
+ balanced = splitCommentsEnd s (EpaComments these)
+ cs' = sortEpAnnComments (ocs <> balanced)
+ put rest
+ return $ EpAnn anc an cs'
+
+ _ -> return $ EpAnn anc an ocs
+
workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
workInComments ocs [] = ocs
workInComments ocs new = cs'
@@ -264,9 +278,14 @@ workInComments ocs new = cs'
= break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) )
new
+sortEpAnnComments :: EpAnnComments -> EpAnnComments
+sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs)
+sortEpAnnComments (EpaCommentsBalanced pc fc)
+ = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc)
+
insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment])
insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs
- = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3)
+ = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3)
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs))
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs))
where
@@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
cs' = workInComments (comments an1) stay
_ -> (an1,cs0a)
- (mexports', an3, cs1) =
- case mexports of
- Nothing -> (Nothing, an2, cs0b)
- Just exports -> (Just exports', an3', cse)
- where
- (csh', cs0b') = case am_exports $ anns an2 of
- (tokOP, _tokCP, _tokCommas) ->
- case tokOP of
- (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n)
- where
- (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) )
- cs0b
-
- _ -> ([], cs0b)
- hc1' = workInComments (comments an2) csh'
- an3' = an2 { comments = hc1' }
- (exports', cse) = allocPreceding exports cs0b'
- (imports0, cs2) = allocPreceding imports cs1
+ (imports0, cs2) = allocPreceding imports cs0b
(imports', hc0i) = balanceFirstLocatedAComments imports0
(decls0, cs3) = allocPreceding decls cs2
@@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
-- Either hc0i or hc0d should have comments. Combine them
hc0 = hc0i ++ hc0d
- (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0
- hc2 = workInComments (comments an3) hc1
- an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 }
+ (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0
+ hc2 = workInComments (comments an2) hc1
+ an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 }
allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment])
allocPreceding [] cs' = ([], cs')
@@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c)
annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c)
annListBracketsLocs ListNone = (noAnn, noAnn)
-
data SplitWhere = Before | After
splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment])
@@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p'
-- ---------------------------------------------------------------------
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
+fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann
+
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan
+fullSpanFromEpAnnA (EpAnn anc tas _) = rr
+ where
+ r = epaLocationRealSrcSpan anc
+ trailing_loc ta = case ta_location ta of
+ EpaSpan (RealSrcSpan s _) -> [s]
+ _ -> []
+ rr = case reverse (concatMap trailing_loc tas) of
+ [] -> r
+ (s:_) -> combineRealSrcSpans r s
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
+splitComments p cs = (before, middle, after)
+ where
+ cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmpe (L _ _) = True
+
+ cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
+ cmpb (L _ _) = True
+
+ (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
+ (before, middle) = break cmpb beforeEnd
+
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsEnd p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- | Split comments into ones occurring before the start of the reference
+-- span, and those after it.
+splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsStart p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- ---------------------------------------------------------------------
+
ghcCommentText :: LEpaComment -> String
ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s
ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dddcdee342a578bbcc4601e010bcfe…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dddcdee342a578bbcc4601e010bcfe…
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
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 25 Aug '26
by Marge Bot (＠marge-bot) 25 Aug '26
25 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
fbaac93d by Andreas Klebinger at 2026-08-25T10:15:41-04:00
rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
We accidentally operated over `uint64_t*` when we should use `uint8_t`.
Fixes #27569
- - - - -
b8729895 by Zubin Duggal at 2026-08-25T10:15:43-04:00
ghc-internal: annotateSTM should use catchSTM# rather than catch#
A catch# frame inside a transaction breaks retry and async exception
delivery.
Fixes #27657
- - - - -
dddcdee3 by Alan Zimmerman at 2026-08-25T10:15:43-04:00
EPA: Uses Parsers.parseModule for exactprint tests
Parsers.parseModule is the advertised way to parse for use for exact
printing in the ghc-exactprint library. This commit updates the GHC
exact print testing to use it.
This requires moving the comment balancing that was occurring
only in the test path into the advertising parser path, so it moves
from Transforms.hs to Utils.hs.
Also update the comment adding to honour trailing annotations
- - - - -
13 changed files:
- + changelog.d/T27657
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- rts/linker/elf_reloc_riscv64.c
- + testsuite/tests/concurrent/should_run/T27657a.hs
- + testsuite/tests/concurrent/should_run/T27657a.stdout
- + testsuite/tests/concurrent/should_run/T27657b.hs
- + testsuite/tests/concurrent/should_run/T27657b.stdout
- testsuite/tests/concurrent/should_run/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
changelog.d/T27657
=====================================
@@ -0,0 +1,9 @@
+section: base
+issues: #27657
+mrs: !16508
+synopsis:
+ Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
+description:
+ ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
+ ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
+ correct way to catch exceptions inside STM.
=====================================
libraries/ghc-internal/src/GHC/Internal/STM.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation)
import GHC.Internal.Exception.Type (WhileHandling(..))
import GHC.Internal.Maybe (Maybe(..))
import GHC.Internal.Prim (
- RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
+ RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
)
import GHC.Internal.Prim.PtrEq (sameTVar#)
@@ -213,7 +213,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
-- | Execute an 'STM' action, adding the given 'ExceptionContext'
-- to any thrown synchronous exceptions.
annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
-annotateSTM ann (STM io) = STM (catch# io handler)
+annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657
where
handler se = raiseIO# (addExceptionContext ann se)
=====================================
rts/linker/elf_reloc_riscv64.c
=====================================
@@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) {
/* The main object code */
void *codeBegin = oc->image + oc->misalignment;
- __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize));
+ __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize));
/* Jump Islands */
__builtin___clear_cache((void *)oc->symbol_extras,
=====================================
testsuite/tests/concurrent/should_run/T27657a.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO
+-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper.
+
+import Control.Exception
+import GHC.Conc
+
+main :: IO ()
+main = do
+ r <- atomically $
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) -> retry)
+ `orElse` pure "T27657a: completed"
+ putStrLn r
=====================================
testsuite/tests/concurrent/should_run/T27657a.stdout
=====================================
@@ -0,0 +1 @@
+T27657a: completed
=====================================
testsuite/tests/concurrent/should_run/T27657b.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- An async exception delivered while a catchSTM handler runs must abort the
+-- transaction, not be swallowed by a restart of the invalidated one.
+
+import Control.Concurrent.MVar
+import Control.Exception
+import GHC.Conc
+
+waitParked :: ThreadId -> IO ()
+waitParked t = do
+ s <- threadStatus t
+ case s of
+ ThreadBlocked BlockedOnMVar -> pure ()
+ _ -> threadDelay 1000 >> waitParked t
+
+main :: IO ()
+main = do
+ tv <- newTVarIO (0 :: Int)
+ park <- newEmptyMVar
+ result <- newEmptyMVar
+ t <- forkIO $ do
+ r <- try $ atomically $ do
+ v <- readTVar tv
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) ->
+ if v == 0
+ then do unsafeIOToSTM (takeMVar park)
+ pure "handler resumed"
+ else pure "transaction restarted, exception dropped")
+ putMVar result (r :: Either SomeException String)
+ -- parked in the handler, so t cannot revalidate its trec before delivery
+ waitParked t
+ atomically (writeTVar tv 1)
+ killThread t
+ r <- takeMVar result
+ putStrLn $ case r of
+ Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered"
+ | otherwise -> "T27657b: unexpected exception: " ++ displayException e
+ Right s -> "T27657b: FAILED, " ++ s
=====================================
testsuite/tests/concurrent/should_run/T27657b.stdout
=====================================
@@ -0,0 +1 @@
+T27657b: killThread delivered
=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -340,3 +340,6 @@ test('T27105_fail',
extra_run_opts('+RTS -C0.2 -RTS'), expect_fail,
run_timeout_multiplier(0.05)],
multimod_compile_and_run, ['T27105.hs', ''])
+
+test('T27657a', normal, compile_and_run, [''])
+test('T27657b', normal, compile_and_run, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where
Just exps -> do
let (op,cp,tcs) = am_exports $ anns an0
op' <- markEpToken op
- exps' <- mapM markAnnotated exps
+ exps' <- mapM markAnnotated (filter notIEDoc exps)
tcs' <- mapM markEpToken tcs
cp' <- markEpToken cp
return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}})
=====================================
utils/check-exact/Main.hs
=====================================
@@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Test17519.hs" Nothing
-- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing
-- "../../testsuite/tests/printer/Test19798.hs" Nothing
- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ -- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ "../../testsuite/tests/printer/Haddock1.hs" Nothing
-- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing
-- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing
@@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8
testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO ()
testOneFile _ libdir fileName mchanger = do
- (p,_toks) <- parseOneFile libdir fileName
+ p <- parseOneFile libdir fileName
let
origAst = ppAst p
pped = exactPrint p
@@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do
changedSource <- readFile newFile
return (expectedSource == changedSource, expectedSource, changedSource)
- (p',_) <- parseOneFile libdir newFile
+ p' <- parseOneFile libdir newFile
let newAstStr :: String
newAstStr = ppAst p'
writeBinFile newAstFile newAstStr
@@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do
ppAst :: Data a => a -> String
ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast
-
-parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token])
+parseOneFile :: FilePath -> FilePath -> IO ParsedSource
parseOneFile libdir fileName = do
- res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName
+ res <- Parsers.parseModule libdir fileName
case res of
Left m -> error (internalDebugShowMessages m)
- Right (injectedComments, _dflags, pmod) -> do
- let !pmodWithComments = insertCppComments pmod injectedComments
- return (pmodWithComments, [])
+ Right pmod -> return pmod
-- ---------------------------------------------------------------------
@@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do
- let (oldDecls) = map unWrapValBind bs
- -- let decls = s:d:oldDecls
+ let oldDecls = map unWrapValBind bs
let oldDecls' = captureLineSpacing oldDecls
let (VbSig o:oldBinds) = map wrapValBind oldDecls'
o' = setEntryDP o (DifferentLine 2 0)
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -46,6 +46,7 @@ module Parsers (
) where
import Preprocess
+import Utils
import Data.Functor (void)
@@ -270,7 +271,10 @@ postParseTransform
-> Either a (GHC.ParsedSource)
postParseTransform parseRes = fmap mkAnns parseRes
where
- mkAnns (_cs, _, m) = fixModuleComments m
+ mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs)
+ noIEDoc (GHC.L l m) = case GHC.hsmodExports m of
+ Nothing -> GHC.L l m
+ Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps }
fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource
fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail
import GHC hiding (parseModule, parsedSource)
import GHC.Parser.PostProcess ( wrapValBind )
import GHC.Data.FastString
-import GHC.Types.SrcLoc
import Data.Data
import Data.List (unsnoc)
@@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r)
(a',b') = balanceComments a b
r = balanceCommentsList' (b':ls)
+balanceCommentsListA :: [LocatedA a ] -> [LocatedA a]
+balanceCommentsListA [] = []
+balanceCommentsListA [x] = [x]
+balanceCommentsListA (a:b:ls) = (a':r)
+ where
+ (a',b') = balanceCommentsA a b
+ r = balanceCommentsListA (b':ls)
+
-- |The GHC parser puts all comments appearing between the end of one AST
-- item and the beginning of the next as 'annPriorComments' for the second one.
-- This function takes two adjacent AST items and moves any 'annPriorComments'
@@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt)
(HsValBinds _ vb') -> vb'
_ -> ValBinds noExtField []
-
-balanceCommentsListA :: [LocatedA a] -> [LocatedA a]
-balanceCommentsListA [] = []
-balanceCommentsListA [x] = [x]
-balanceCommentsListA (a:b:ls) = (a':r)
- where
- (a',b') = balanceCommentsA a b
- r = balanceCommentsListA (b':ls)
-
-- |Prior to moving an AST element, make sure any trailing comments belonging to
-- it are attached to it, and not the following element. Of necessity this is a
-- heuristic process, to be tuned later. Possibly a variant should be provided
@@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs)
-- ---------------------------------------------------------------------
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
-splitComments p cs = (before, middle, after)
- where
- cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmpe (L _ _) = True
-
- cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
- cmpb (L _ _) = True
-
- (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
- (before, middle) = break cmpb beforeEnd
-
-
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsEnd p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
--- | Split comments into ones occurring before the start of the reference
--- span, and those after it.
-splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsStart p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u)
=> LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u)
moveLeadingComments (L la a) lb = (L la' a, lb')
@@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs)
anchorFromLocatedA :: LocatedA a -> RealSrcSpan
anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc
--- | Get the full span of interest for comments from a LocatedA.
--- This extends up to the last TrailingAnn
-fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
-fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr
- where
- r = epaLocationRealSrcSpan anc
- trailing_loc ta = case ta_location ta of
- EpaSpan (RealSrcSpan s _) -> [s]
- _ -> []
- rr = case reverse (concatMap trailing_loc tas) of
- [] -> r
- (s:_) -> combineRealSrcSpans r s
-
-- ---------------------------------------------------------------------
balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs))
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
(p2, remaining) = insertTopLevelCppComments p1 toplevel
addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
- addCommentsListItem = addComments
+ addCommentsListItem = addCommentsA
addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList)
addCommentsList = addComments
@@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
_ -> return $ EpAnn anc an ocs
+ addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
+ addCommentsA ann@(EpAnn anc an ocs) = do
+ case anc of
+ EpaSpan (RealSrcSpan s _) -> do
+ unAllocated <- get
+ let
+ (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated
+ balanced = splitCommentsEnd s (EpaComments these)
+ cs' = sortEpAnnComments (ocs <> balanced)
+ put rest
+ return $ EpAnn anc an cs'
+
+ _ -> return $ EpAnn anc an ocs
+
workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
workInComments ocs [] = ocs
workInComments ocs new = cs'
@@ -264,9 +278,14 @@ workInComments ocs new = cs'
= break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) )
new
+sortEpAnnComments :: EpAnnComments -> EpAnnComments
+sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs)
+sortEpAnnComments (EpaCommentsBalanced pc fc)
+ = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc)
+
insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment])
insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs
- = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3)
+ = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3)
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs))
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs))
where
@@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
cs' = workInComments (comments an1) stay
_ -> (an1,cs0a)
- (mexports', an3, cs1) =
- case mexports of
- Nothing -> (Nothing, an2, cs0b)
- Just exports -> (Just exports', an3', cse)
- where
- (csh', cs0b') = case am_exports $ anns an2 of
- (tokOP, _tokCP, _tokCommas) ->
- case tokOP of
- (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n)
- where
- (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) )
- cs0b
-
- _ -> ([], cs0b)
- hc1' = workInComments (comments an2) csh'
- an3' = an2 { comments = hc1' }
- (exports', cse) = allocPreceding exports cs0b'
- (imports0, cs2) = allocPreceding imports cs1
+ (imports0, cs2) = allocPreceding imports cs0b
(imports', hc0i) = balanceFirstLocatedAComments imports0
(decls0, cs3) = allocPreceding decls cs2
@@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
-- Either hc0i or hc0d should have comments. Combine them
hc0 = hc0i ++ hc0d
- (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0
- hc2 = workInComments (comments an3) hc1
- an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 }
+ (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0
+ hc2 = workInComments (comments an2) hc1
+ an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 }
allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment])
allocPreceding [] cs' = ([], cs')
@@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c)
annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c)
annListBracketsLocs ListNone = (noAnn, noAnn)
-
data SplitWhere = Before | After
splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment])
@@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p'
-- ---------------------------------------------------------------------
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
+fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann
+
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan
+fullSpanFromEpAnnA (EpAnn anc tas _) = rr
+ where
+ r = epaLocationRealSrcSpan anc
+ trailing_loc ta = case ta_location ta of
+ EpaSpan (RealSrcSpan s _) -> [s]
+ _ -> []
+ rr = case reverse (concatMap trailing_loc tas) of
+ [] -> r
+ (s:_) -> combineRealSrcSpans r s
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
+splitComments p cs = (before, middle, after)
+ where
+ cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmpe (L _ _) = True
+
+ cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
+ cmpb (L _ _) = True
+
+ (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
+ (before, middle) = break cmpb beforeEnd
+
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsEnd p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- | Split comments into ones occurring before the start of the reference
+-- span, and those after it.
+splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsStart p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- ---------------------------------------------------------------------
+
ghcCommentText :: LEpaComment -> String
ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s
ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e885a4e595f03aa11669eef7e4520c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e885a4e595f03aa11669eef7e4520c…
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
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 25 Aug '26
by Marge Bot (＠marge-bot) 25 Aug '26
25 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
fbaac93d by Andreas Klebinger at 2026-08-25T10:15:41-04:00
rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
We accidentally operated over `uint64_t*` when we should use `uint8_t`.
Fixes #27569
- - - - -
b8729895 by Zubin Duggal at 2026-08-25T10:15:43-04:00
ghc-internal: annotateSTM should use catchSTM# rather than catch#
A catch# frame inside a transaction breaks retry and async exception
delivery.
Fixes #27657
- - - - -
dddcdee3 by Alan Zimmerman at 2026-08-25T10:15:43-04:00
EPA: Uses Parsers.parseModule for exactprint tests
Parsers.parseModule is the advertised way to parse for use for exact
printing in the ghc-exactprint library. This commit updates the GHC
exact print testing to use it.
This requires moving the comment balancing that was occurring
only in the test path into the advertising parser path, so it moves
from Transforms.hs to Utils.hs.
Also update the comment adding to honour trailing annotations
- - - - -
13 changed files:
- + changelog.d/T27657
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- rts/linker/elf_reloc_riscv64.c
- + testsuite/tests/concurrent/should_run/T27657a.hs
- + testsuite/tests/concurrent/should_run/T27657a.stdout
- + testsuite/tests/concurrent/should_run/T27657b.hs
- + testsuite/tests/concurrent/should_run/T27657b.stdout
- testsuite/tests/concurrent/should_run/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
changelog.d/T27657
=====================================
@@ -0,0 +1,9 @@
+section: base
+issues: #27657
+mrs: !16508
+synopsis:
+ Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
+description:
+ ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
+ ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
+ correct way to catch exceptions inside STM.
=====================================
libraries/ghc-internal/src/GHC/Internal/STM.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation)
import GHC.Internal.Exception.Type (WhileHandling(..))
import GHC.Internal.Maybe (Maybe(..))
import GHC.Internal.Prim (
- RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
+ RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
)
import GHC.Internal.Prim.PtrEq (sameTVar#)
@@ -213,7 +213,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
-- | Execute an 'STM' action, adding the given 'ExceptionContext'
-- to any thrown synchronous exceptions.
annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
-annotateSTM ann (STM io) = STM (catch# io handler)
+annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657
where
handler se = raiseIO# (addExceptionContext ann se)
=====================================
rts/linker/elf_reloc_riscv64.c
=====================================
@@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) {
/* The main object code */
void *codeBegin = oc->image + oc->misalignment;
- __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize));
+ __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize));
/* Jump Islands */
__builtin___clear_cache((void *)oc->symbol_extras,
=====================================
testsuite/tests/concurrent/should_run/T27657a.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO
+-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper.
+
+import Control.Exception
+import GHC.Conc
+
+main :: IO ()
+main = do
+ r <- atomically $
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) -> retry)
+ `orElse` pure "T27657a: completed"
+ putStrLn r
=====================================
testsuite/tests/concurrent/should_run/T27657a.stdout
=====================================
@@ -0,0 +1 @@
+T27657a: completed
=====================================
testsuite/tests/concurrent/should_run/T27657b.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- An async exception delivered while a catchSTM handler runs must abort the
+-- transaction, not be swallowed by a restart of the invalidated one.
+
+import Control.Concurrent.MVar
+import Control.Exception
+import GHC.Conc
+
+waitParked :: ThreadId -> IO ()
+waitParked t = do
+ s <- threadStatus t
+ case s of
+ ThreadBlocked BlockedOnMVar -> pure ()
+ _ -> threadDelay 1000 >> waitParked t
+
+main :: IO ()
+main = do
+ tv <- newTVarIO (0 :: Int)
+ park <- newEmptyMVar
+ result <- newEmptyMVar
+ t <- forkIO $ do
+ r <- try $ atomically $ do
+ v <- readTVar tv
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) ->
+ if v == 0
+ then do unsafeIOToSTM (takeMVar park)
+ pure "handler resumed"
+ else pure "transaction restarted, exception dropped")
+ putMVar result (r :: Either SomeException String)
+ -- parked in the handler, so t cannot revalidate its trec before delivery
+ waitParked t
+ atomically (writeTVar tv 1)
+ killThread t
+ r <- takeMVar result
+ putStrLn $ case r of
+ Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered"
+ | otherwise -> "T27657b: unexpected exception: " ++ displayException e
+ Right s -> "T27657b: FAILED, " ++ s
=====================================
testsuite/tests/concurrent/should_run/T27657b.stdout
=====================================
@@ -0,0 +1 @@
+T27657b: killThread delivered
=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -340,3 +340,6 @@ test('T27105_fail',
extra_run_opts('+RTS -C0.2 -RTS'), expect_fail,
run_timeout_multiplier(0.05)],
multimod_compile_and_run, ['T27105.hs', ''])
+
+test('T27657a', normal, compile_and_run, [''])
+test('T27657b', normal, compile_and_run, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where
Just exps -> do
let (op,cp,tcs) = am_exports $ anns an0
op' <- markEpToken op
- exps' <- mapM markAnnotated exps
+ exps' <- mapM markAnnotated (filter notIEDoc exps)
tcs' <- mapM markEpToken tcs
cp' <- markEpToken cp
return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}})
=====================================
utils/check-exact/Main.hs
=====================================
@@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Test17519.hs" Nothing
-- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing
-- "../../testsuite/tests/printer/Test19798.hs" Nothing
- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ -- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ "../../testsuite/tests/printer/Haddock1.hs" Nothing
-- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing
-- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing
@@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8
testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO ()
testOneFile _ libdir fileName mchanger = do
- (p,_toks) <- parseOneFile libdir fileName
+ p <- parseOneFile libdir fileName
let
origAst = ppAst p
pped = exactPrint p
@@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do
changedSource <- readFile newFile
return (expectedSource == changedSource, expectedSource, changedSource)
- (p',_) <- parseOneFile libdir newFile
+ p' <- parseOneFile libdir newFile
let newAstStr :: String
newAstStr = ppAst p'
writeBinFile newAstFile newAstStr
@@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do
ppAst :: Data a => a -> String
ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast
-
-parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token])
+parseOneFile :: FilePath -> FilePath -> IO ParsedSource
parseOneFile libdir fileName = do
- res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName
+ res <- Parsers.parseModule libdir fileName
case res of
Left m -> error (internalDebugShowMessages m)
- Right (injectedComments, _dflags, pmod) -> do
- let !pmodWithComments = insertCppComments pmod injectedComments
- return (pmodWithComments, [])
+ Right pmod -> return pmod
-- ---------------------------------------------------------------------
@@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do
- let (oldDecls) = map unWrapValBind bs
- -- let decls = s:d:oldDecls
+ let oldDecls = map unWrapValBind bs
let oldDecls' = captureLineSpacing oldDecls
let (VbSig o:oldBinds) = map wrapValBind oldDecls'
o' = setEntryDP o (DifferentLine 2 0)
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -46,6 +46,7 @@ module Parsers (
) where
import Preprocess
+import Utils
import Data.Functor (void)
@@ -270,7 +271,10 @@ postParseTransform
-> Either a (GHC.ParsedSource)
postParseTransform parseRes = fmap mkAnns parseRes
where
- mkAnns (_cs, _, m) = fixModuleComments m
+ mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs)
+ noIEDoc (GHC.L l m) = case GHC.hsmodExports m of
+ Nothing -> GHC.L l m
+ Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps }
fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource
fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail
import GHC hiding (parseModule, parsedSource)
import GHC.Parser.PostProcess ( wrapValBind )
import GHC.Data.FastString
-import GHC.Types.SrcLoc
import Data.Data
import Data.List (unsnoc)
@@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r)
(a',b') = balanceComments a b
r = balanceCommentsList' (b':ls)
+balanceCommentsListA :: [LocatedA a ] -> [LocatedA a]
+balanceCommentsListA [] = []
+balanceCommentsListA [x] = [x]
+balanceCommentsListA (a:b:ls) = (a':r)
+ where
+ (a',b') = balanceCommentsA a b
+ r = balanceCommentsListA (b':ls)
+
-- |The GHC parser puts all comments appearing between the end of one AST
-- item and the beginning of the next as 'annPriorComments' for the second one.
-- This function takes two adjacent AST items and moves any 'annPriorComments'
@@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt)
(HsValBinds _ vb') -> vb'
_ -> ValBinds noExtField []
-
-balanceCommentsListA :: [LocatedA a] -> [LocatedA a]
-balanceCommentsListA [] = []
-balanceCommentsListA [x] = [x]
-balanceCommentsListA (a:b:ls) = (a':r)
- where
- (a',b') = balanceCommentsA a b
- r = balanceCommentsListA (b':ls)
-
-- |Prior to moving an AST element, make sure any trailing comments belonging to
-- it are attached to it, and not the following element. Of necessity this is a
-- heuristic process, to be tuned later. Possibly a variant should be provided
@@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs)
-- ---------------------------------------------------------------------
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
-splitComments p cs = (before, middle, after)
- where
- cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmpe (L _ _) = True
-
- cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
- cmpb (L _ _) = True
-
- (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
- (before, middle) = break cmpb beforeEnd
-
-
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsEnd p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
--- | Split comments into ones occurring before the start of the reference
--- span, and those after it.
-splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsStart p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u)
=> LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u)
moveLeadingComments (L la a) lb = (L la' a, lb')
@@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs)
anchorFromLocatedA :: LocatedA a -> RealSrcSpan
anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc
--- | Get the full span of interest for comments from a LocatedA.
--- This extends up to the last TrailingAnn
-fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
-fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr
- where
- r = epaLocationRealSrcSpan anc
- trailing_loc ta = case ta_location ta of
- EpaSpan (RealSrcSpan s _) -> [s]
- _ -> []
- rr = case reverse (concatMap trailing_loc tas) of
- [] -> r
- (s:_) -> combineRealSrcSpans r s
-
-- ---------------------------------------------------------------------
balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs))
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
(p2, remaining) = insertTopLevelCppComments p1 toplevel
addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
- addCommentsListItem = addComments
+ addCommentsListItem = addCommentsA
addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList)
addCommentsList = addComments
@@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
_ -> return $ EpAnn anc an ocs
+ addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
+ addCommentsA ann@(EpAnn anc an ocs) = do
+ case anc of
+ EpaSpan (RealSrcSpan s _) -> do
+ unAllocated <- get
+ let
+ (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated
+ balanced = splitCommentsEnd s (EpaComments these)
+ cs' = sortEpAnnComments (ocs <> balanced)
+ put rest
+ return $ EpAnn anc an cs'
+
+ _ -> return $ EpAnn anc an ocs
+
workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
workInComments ocs [] = ocs
workInComments ocs new = cs'
@@ -264,9 +278,14 @@ workInComments ocs new = cs'
= break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) )
new
+sortEpAnnComments :: EpAnnComments -> EpAnnComments
+sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs)
+sortEpAnnComments (EpaCommentsBalanced pc fc)
+ = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc)
+
insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment])
insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs
- = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3)
+ = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3)
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs))
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs))
where
@@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
cs' = workInComments (comments an1) stay
_ -> (an1,cs0a)
- (mexports', an3, cs1) =
- case mexports of
- Nothing -> (Nothing, an2, cs0b)
- Just exports -> (Just exports', an3', cse)
- where
- (csh', cs0b') = case am_exports $ anns an2 of
- (tokOP, _tokCP, _tokCommas) ->
- case tokOP of
- (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n)
- where
- (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) )
- cs0b
-
- _ -> ([], cs0b)
- hc1' = workInComments (comments an2) csh'
- an3' = an2 { comments = hc1' }
- (exports', cse) = allocPreceding exports cs0b'
- (imports0, cs2) = allocPreceding imports cs1
+ (imports0, cs2) = allocPreceding imports cs0b
(imports', hc0i) = balanceFirstLocatedAComments imports0
(decls0, cs3) = allocPreceding decls cs2
@@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
-- Either hc0i or hc0d should have comments. Combine them
hc0 = hc0i ++ hc0d
- (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0
- hc2 = workInComments (comments an3) hc1
- an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 }
+ (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0
+ hc2 = workInComments (comments an2) hc1
+ an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 }
allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment])
allocPreceding [] cs' = ([], cs')
@@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c)
annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c)
annListBracketsLocs ListNone = (noAnn, noAnn)
-
data SplitWhere = Before | After
splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment])
@@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p'
-- ---------------------------------------------------------------------
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
+fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann
+
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan
+fullSpanFromEpAnnA (EpAnn anc tas _) = rr
+ where
+ r = epaLocationRealSrcSpan anc
+ trailing_loc ta = case ta_location ta of
+ EpaSpan (RealSrcSpan s _) -> [s]
+ _ -> []
+ rr = case reverse (concatMap trailing_loc tas) of
+ [] -> r
+ (s:_) -> combineRealSrcSpans r s
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
+splitComments p cs = (before, middle, after)
+ where
+ cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmpe (L _ _) = True
+
+ cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
+ cmpb (L _ _) = True
+
+ (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
+ (before, middle) = break cmpb beforeEnd
+
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsEnd p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- | Split comments into ones occurring before the start of the reference
+-- span, and those after it.
+splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsStart p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- ---------------------------------------------------------------------
+
ghcCommentText :: LEpaComment -> String
ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s
ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e885a4e595f03aa11669eef7e4520c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e885a4e595f03aa11669eef7e4520c…
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
1
0
[Git][ghc/ghc][wip/romes/27514] 2 commits: Rule-based downsweep with structured concurrency
by sheaf (＠sheaf) 25 Aug '26
by sheaf (＠sheaf) 25 Aug '26
25 Aug '26
sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC
Commits:
4c4d62bc by sheaf at 2026-08-25T15:06:56+02:00
Rule-based downsweep with structured concurrency
- - - - -
81cdb258 by sheaf at 2026-08-25T15:06:56+02:00
2-phase Cache/Search Finder monad
- - - - -
50 changed files:
- compiler/GHC.hs
- compiler/GHC/Builtin.hs
- + compiler/GHC/Data/Dependent.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Concurrency.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeAction.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/MakeSem.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Plugin.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/UnresolvedImport.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/Types.hs
- + compiler/GHC/Utils/Concurrent/Scope.hs
- compiler/GHC/Utils/TmpFs.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
- ghc/Main.hs
- linters/lint-codes/LintCodes/Static.hs
- testsuite/tests/diagnostic-codes/codes.stdout
- testsuite/tests/driver/T27461/Makefile
- + testsuite/tests/driver/T27461/T27461c.stderr
- testsuite/tests/driver/T27461/all.T
- + testsuite/tests/driver/T27461/src/Wrong.hs
- testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs
- testsuite/tests/ghc-api/downsweep/OldModLocation.hs
- testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
- testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
- testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs
- testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
- testsuite/tests/splice-imports/SI35.hs
- utils/check-ppr/Main.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff3a0fccc254ac4f85aff5e394f60c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff3a0fccc254ac4f85aff5e394f60c…
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
1
0
25 Aug '26
sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC
Commits:
ff3a0fcc by sheaf at 2026-08-25T15:04:16+02:00
2-phase Cache/Search Finder monad
- - - - -
18 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Concurrency.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Plugin.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Unit/Finder.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- linters/lint-codes/LintCodes/Static.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -1693,14 +1693,14 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
case home of
Just m -> return m
Nothing -> liftIO $ do
- res <- findImportedModule hsc_env LookupUser mod_name pkgqual
+ res <- runFinderM $ findImportedModule hsc_env LookupUser mod_name pkgqual
case res of
Found loc m | notHomeModuleMaybe mhome_unit m -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err
_ -> liftIO $ do
- res <- findImportedModule hsc_env LookupUser mod_name pkgqual
+ res <- runFinderM $ findImportedModule hsc_env LookupUser mod_name pkgqual
case res of
Found _ m -> return m
err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err
@@ -1741,7 +1741,7 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let dflags = hsc_dflags hsc_env
let sec = initSourceErrorContext dflags
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units LookupUser mod_name NoPkgQual
+ res <- runFinderM $ findExposedPackageModule fc fopts units LookupUser mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err
@@ -1791,7 +1791,7 @@ lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do
let dflags = hsc_dflags hsc_env
let sec = initSourceErrorContext dflags
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units LookupUser mod_name NoPkgQual
+ res <- runFinderM $ findExposedPackageModule fc fopts units LookupUser mod_name NoPkgQual
case res of
Found _ m -> return [m]
err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Driver/Concurrency.hs
=====================================
@@ -3,7 +3,7 @@
{-# LANGUAGE BlockArguments #-}
module GHC.Driver.Concurrency
- ( -- * Worker limit and concurrency
+ ( -- * Worker limit
WorkerLimit(..)
-- * Concurrent worker scheduling
@@ -17,7 +17,7 @@ module GHC.Driver.Concurrency
, runCoordinatingWorkers
, WorkerCoordination(runBlockingAction)
- -- ** Demand-driven work
+ -- ** Demand-driven work (push-based concurrency)
, Demand
, Rule
, RuleAnswer(..)
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -348,7 +348,7 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
home_uid = homeUnitId (hsc_home_unit hsc_env)
env = DownsweepEnv
{ ds_hsc_env = hsc_env
- , ds_mode = DownsweepUseGiven
+ , ds_mode = DownsweepUseFixed
, ds_prior = Map.empty
, ds_excl_mods = []
}
@@ -407,7 +407,7 @@ downsweepInstalledModules hsc_env mods = do
-- to this function should already know that we can find the modules we need
-- to load.
for_ installed_mods $ \ i ->
- findExactModule hsc_env i NotBoot >>= \case
+ runFinderM (findExactModule hsc_env i NotBoot) >>= \case
InstalledFound {} -> return ()
_ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $
text "downsweepInstalledModules: Could not find installed module" <+> ppr i
@@ -543,13 +543,14 @@ instance Outputable (Some DownsweepQuery) where
data DownsweepMode
-- | @--make@: home modules are summarised from source and compiled.
= DownsweepUseCompile
- -- | One-shot mode: home modules are taken from their interface files, which
- -- must already exist on disk.
+ -- | Home modules are taken from their interface files (one-shot mode), or
+ -- from the module graph when already present there (GHCi's interactive
+ -- imports, see Note [runTcInteractive module graph]).
+ --
+ -- Whether a module actually exists is decided by its 'Fixed' query: a
+ -- module whose interface cannot be found or read produces no graph node,
+ -- and imports resolving to it produce no edge.
| DownsweepUseFixed
- -- | GHCi's interactive imports: home modules are assumed to be in the module
- -- graph already, so their interfaces are taken as given rather than looked
- -- for on disk. See Note [runTcInteractive module graph].
- | DownsweepUseGiven
-- | A 'ModSummary's provenance during downsweep: an old previously constructed
-- ModSummary, that might be potentially outdated, or a freshly constructed one
@@ -725,13 +726,19 @@ downsweepRule :: DownsweepEnv -> Demand DownsweepQuery -> Rule DownsweepQuery
downsweepRule env demand query =
case query of
- Resolve home_uid lkp -> pure $ AnswerDefer \ worker_env -> do
- -- NB: it might be worth answering inline when the resolution is
- -- immediately available from the finder cache.
- resolution <-
- resolveDownsweepImport (worker_local_env worker_env) home_uid lkp
- demandResolution demand home_uid resolution
- return resolution
+ Resolve home_uid lkp -> do
+ mbCached <- runFinderCacheM $ resolveDownsweepImport env home_uid lkp
+ case mbCached of
+ InCache resolution -> do
+ demandResolution demand home_uid resolution
+ return $ AnswerInline resolution
+ NotInCache search -> return $ AnswerDefer \ _worker_env -> do
+ -- The search closes over the downsweep environment rather than the
+ -- worker-local one; that is fine because it neither logs nor uses
+ -- temporary files.
+ resolution <- search
+ demandResolution demand home_uid resolution
+ return resolution
Summarise uid path -> pure $ AnswerDefer \ worker_env -> do
result <- summariseHomeSourceFile (worker_local_env worker_env) uid path
@@ -805,41 +812,41 @@ moduleDiscoveries ms = moduleEdgeImports ms ++ boot_source
| IsBoot <- [isBootSummary ms] ]
-- | Resolve a module lookup made from the given home unit.
-resolveDownsweepImport :: DownsweepEnv -> UnitId -> UnresolvedImport PkgQual -> IO ImportResolution
+resolveDownsweepImport :: DownsweepEnv -> UnitId -> UnresolvedImport PkgQual -> FinderM ImportResolution
resolveDownsweepImport env home_uid lkp
| ui_mod_name lkp `elem` ds_excl_mods env
- = return ResolvedNotFound
+ = pure ResolvedNotFound
| otherwise
- = do
- found <- resolveImport hsc_env lkp
- case found of
- Found location mod
- | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env
- -> home_module location mod
- | VirtUnit iud <- moduleUnit mod
- , not (isHomeModule home_unit mod)
- -> return $ ResolvedInstantiation iud
- | otherwise
- -> return $ ResolvedExternal (moduleUnitId mod)
- _ -> return ResolvedNotFound
- -- Not found. If it is TRULY not found at all, we'll error when we
- -- actually try to compile.
+ = classify =<< resolveImport hsc_env lkp
where
home_unit = ue_unitHomeUnit home_uid (hsc_unit_env (ds_hsc_env env))
-- All operations happen relative to the home unit the import was made from.
hsc_env = hscSetActiveHomeUnit home_unit (ds_hsc_env env)
+ classify :: FindResult -> FinderM ImportResolution
+ classify = \case
+ Found location mod
+ | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env
+ -> home_module location mod
+ | VirtUnit iud <- moduleUnit mod
+ , not (isHomeModule home_unit mod)
+ -> pure $ ResolvedInstantiation iud
+ | otherwise
+ -> pure $ ResolvedExternal (moduleUnitId mod)
+ _ -> pure ResolvedNotFound
+ -- Not found. If it is TRULY not found at all, we'll error when we
+ -- actually try to compile.
+
+ home_module :: ModLocation -> Module -> FinderM ImportResolution
home_module location mod = case ds_mode env of
DownsweepUseCompile ->
- return $ case ml_hs_file_ospath location of
+ pure $ case ml_hs_file_ospath location of
Just path -> ResolvedHome key path
Nothing -> ResolvedNotFound
- DownsweepUseFixed -> do
- -- The finder returns a path to the .hi(-boot) file even if it doesn't
- -- actually exist, so check before concluding it's there.
- exists <- doesFileExist (ml_hi_file location)
- return $ if exists then ResolvedFixed key else ResolvedNotFound
- DownsweepUseGiven -> return $ ResolvedFixed key
+ DownsweepUseFixed ->
+ -- The resulting 'Fixed' query will determine whether the
+ -- interface file actually exists (see 'DownsweepUseFixed').
+ pure $ ResolvedFixed key
where
key = moduleToMnk mod (ui_boot lkp)
@@ -856,7 +863,7 @@ summariseHomeSourceFile env uid path =
-- it records.
readFixedModule :: DownsweepEnv -> ModNodeKeyWithUid -> IO (Maybe FixedModule)
readFixedModule (DownsweepEnv { ds_hsc_env = hsc_env }) key =
- findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) >>= \case
+ runFinderM (findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)) >>= \case
InstalledFound loc -> do
-- MP: TODO, we should just read the dependency info from the interface rather than either
-- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
@@ -909,9 +916,16 @@ downsweepEdgeTarget answers home_uid lkp =
Nothing -> Nothing
Just (Identity resolution) -> case resolution of
ResolvedNotFound -> Nothing
- ResolvedFixed key -> Just (NodeKey_Module key)
ResolvedExternal uid -> Just (NodeKey_ExternalUnit uid)
ResolvedInstantiation iud -> Just (NodeKey_Unit iud)
+ ResolvedFixed key ->
+ -- Only emit an edge if the target node actually materialised
+ -- (the interface file of a 'Fixed' node might turn out not to exist,
+ -- e.g. due to the self-boot check).
+ case lookupDMap (Fixed key) answers of
+ Just (Identity (Just {}))
+ -> Just (NodeKey_Module key)
+ _ -> Nothing
ResolvedHome key path ->
case lookupDMap (Summarise (mnkUnitId key) path) answers of
Just (Identity (SummariseFound ms)) | msKey ms == key
@@ -1043,7 +1057,7 @@ getRootSummary env target =
{ ui_pkg_qual = ThisPkg (homeUnitId home_unit) }
-- A module target has to name a home module we can compile.
not_found = return $ Left (moduleNotFoundErr uid modl)
- resolution <- resolveDownsweepImport env uid root_imp
+ resolution <- runFinderM $ resolveDownsweepImport env uid root_imp
case resolution of
ResolvedHome key path ->
summarise (Just (uid, root_imp, resolution)) (mnkUnitId key) path
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -318,7 +318,7 @@ warnUnknownModules hsc_env dflags mod_graph = do
hidden_warns = hidden_mods `minusUniqSet` unit_mods
- lookupModule mn = findImportedModule hsc_env LookupUser mn NoPkgQual
+ lookupModule mn = runFinderM $ findImportedModule hsc_env LookupUser mn NoPkgQual
check_reexport mn = do
fr <- lookupModule (reexportFrom mn)
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -300,7 +300,7 @@ findDependency :: HscEnv
findDependency hsc_env (L srcloc imp) include_pkg_deps = do
-- Find the module; this will be fast because
-- we've done it once during downsweep.
- r <- resolveImport hsc_env imp
+ r <- runFinderM $ resolveImport hsc_env imp
case r of
Found loc _
-- Home package: just depend on the .hi or hi-boot file
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -293,7 +293,7 @@ lookupKnownName kk_ns name
loadKnownKeyOccMaps :: IfM lcl (MaybeErr IfaceMessage KnownKeyNameMaps)
loadKnownKeyOccMaps
= do { hsc_env <- getTopEnv
- ; fr <- liftIO $
+ ; fr <- liftIO $ runFinderM $
findImportedModule hsc_env LookupSystem eSSENTIALS_NAME NoPkgQual
; case fr of
Found _ mod -> Succeeded <$> known_key_maps mod
@@ -650,7 +650,7 @@ loadSrcInterface_maybe doc scope mod want_boot maybe_pkg
-- interface; it will call the Finder again, but the ModLocation will be
-- cached from the first search.
= do hsc_env <- getTopEnv
- res <- liftIO $ findImportedModule hsc_env scope mod maybe_pkg
+ res <- liftIO $ runFinderM $ findImportedModule hsc_env scope mod maybe_pkg
case res of
Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
-- TODO: Make sure this error message is good
@@ -1237,7 +1237,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
nest 4 (text "reason:" <+> doc_str)])
-- Look for the file
- mb_found <- liftIO (findExactModule hsc_env mod hi_boot_file)
+ mb_found <- liftIO $ runFinderM $ findExactModule hsc_env mod hi_boot_file
case mb_found of
InstalledFound loc -> do
-- See Note [Home module load error]
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -658,7 +658,7 @@ checkDependencies hsc_env summary iface
classify_imports imports =
liftIO $ traverse (\ (L _ e) ->
let reason = ModuleChanged (ui_mod_name e)
- in classify (ui_level e) reason <$> resolveImport hsc_env e)
+ in classify (ui_level e) reason <$> runFinderM (resolveImport hsc_env e))
imports
logger = hsc_logger hsc_env
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -168,7 +168,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
let fc = ldFinderCache opts
let fopts = ldFinderOpts opts
- mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
+ mb_stuff <- runFinderM $ findHomeModule fc fopts home_unit (moduleName mod)
case mb_stuff of
Found loc _ -> do
from_bc <- ldLoadByteCode opts mod loc
@@ -179,7 +179,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
fallback_no_bytecode home_unit mod = do
let fc = ldFinderCache opts
let fopts = ldFinderOpts opts
- mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
+ mb_stuff <- runFinderM $ findHomeModule fc fopts home_unit (moduleName mod)
case mb_stuff of
Found loc _ -> do
mb_lnk <- findObjectLinkableMaybe mod loc
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -57,7 +57,7 @@ import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS )
import GHC.Types.Name.Reader
import GHC.Types.Unique.DFM
-import GHC.Unit.Finder ( findPluginModule, FindResult(..) )
+import GHC.Unit.Finder ( FindResult(..), runFinderM, findPluginModule )
import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts )
import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) )
import GHC.Unit.Module.ModIface
@@ -345,7 +345,7 @@ lookupRdrNameInModuleForPlugins :: HasDebugCallStack
lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let dflags = hsc_dflags hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule hsc_env mod_name
+ found_module <- runFinderM $ findPluginModule hsc_env mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -118,7 +118,7 @@ import System.Directory ( createDirectoryIfMissing
)
import GHC.Unit.Finder.Types
-import GHC.Unit.Finder (findObjectLinkableMaybe, findHomeModule)
+import GHC.Unit.Finder (findObjectLinkableMaybe, findHomeModule, runFinderM)
import GHC.Driver.Config.Finder (initFinderOpts)
import qualified GHC.Unit.Home.Graph as HUG
@@ -491,7 +491,7 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
case ue_homeUnit unit_env of
Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod)
Just home_unit -> do
- mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod)
+ mb_stuff <- runFinderM $ findHomeModule finder_cache finder_opts home_unit (moduleName mod)
case mb_stuff of
Found loc mod -> found loc mod
_ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -1633,7 +1633,7 @@ metaHandlersTcM runInIO = TH.MetaHandlers {
let home_unit = hsc_home_unit hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
+ r <- liftIO $ runFinderM $ findHomeModule fc fopts home_unit (mkModuleName plugin)
let err = TcRnTHError $ AddInvalidCorePlugin plugin
case r of
Found {} -> addErr err
=====================================
compiler/GHC/Tc/Plugin.hs
=====================================
@@ -104,7 +104,8 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult
findImportedModule mod_name mb_pkg = do
hsc_env <- getTopEnv
- tcPluginIO $ Finder.findImportedModule hsc_env Finder.LookupUser mod_name mb_pkg
+ tcPluginIO $ Finder.runFinderM $
+ Finder.findImportedModule hsc_env Finder.LookupUser mod_name mb_pkg
lookupOrig :: Module -> OccName -> TcPluginM Name
lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -284,7 +284,7 @@ implicitRequirements :: HscEnv
implicitRequirements hsc_env normal_imports
= fmap concat $
forM normal_imports $ \e -> do
- found <- resolveImport hsc_env e
+ found <- runFinderM $ resolveImport hsc_env e
case found of
Found _ mod | notHomeModuleMaybe mhome_unit mod ->
return (uniqDSetToList (moduleFreeHoles mod))
@@ -306,7 +306,7 @@ implicitRequirementsShallow hsc_env normal_imports = go [] normal_imports
go acc [] = pure acc
go accR (e:imports) = do
- found <- resolveImport hsc_env e
+ found <- runFinderM $ resolveImport hsc_env e
let acc' = case found of
Found _ mod | notHomeModuleMaybe mhome_unit mod ->
case moduleUnit mod of
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -4,18 +4,28 @@
-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Module finder
module GHC.Unit.Finder (
+
+ -- * Finder result
FindResult(..),
InstalledFindResult(..),
+
+ -- * Finder cache
FinderOpts(..),
FinderCache(..),
initFinderCache,
+
+ -- ** Finder monad
+ FinderM, runFinderCacheM, runFinderM,
+ InCache(..),
+
+ -- * Finder operations
+ ModuleLookupScope(..),
findImportedModule,
resolveImport,
- ModuleLookupScope(..),
findPluginModule,
findExactModule,
findHomeModule,
@@ -85,6 +95,9 @@ import qualified System.Directory as SD
import qualified System.OsPath as OsPath
import qualified Data.List.NonEmpty as NE
+import GHC.TypeError (ErrorMessage(..), Unsatisfiable, unsatisfiable)
+import Control.Monad.IO.Class
+
type FileExt = OsString -- Filename extension
type BaseName = OsPath -- Basename of file
@@ -173,6 +186,96 @@ getDirHash dir = do
let hash = fingerprintFingerprints s_hashes
return hash
+-- -----------------------------------------------------------------------------
+-- Finder monad, handling finder cache hits
+
+-- | The result of a lookup that consults the finder caches before searching
+-- the file system.
+data InCache a
+ -- | The result was in a cache; no filesystem access was performed.
+ = InCache !a
+ -- | The result was not cached.
+ | NotInCache (IO a) -- ^ search action to compute the result
+ -- (may perform filesystem access)
+ deriving stock Functor
+
+-- | Monad for finder operations.
+--
+-- A finder operation is split into two phases:
+--
+-- - a cache-only phase with no filesystem access,
+-- - from the first cache miss onwards, a residual 'IO' computation that may
+-- access the filesystem.
+newtype FinderM a =
+ FinderM (IO (InCache a))
+ -- ^ Invariant: the I/O action only performs benign I/O (such as reading
+ -- from the finder cache, i.e. 'lookupFinderCache').
+ --
+ -- It is not allowed to perform any filesystem access.
+
+-- | Like 'runFinderM', but separates the finder action into the cache lookup
+-- and the search action.
+runFinderCacheM :: FinderM a -> IO (InCache a)
+runFinderCacheM (FinderM f) = f
+
+-- | Run a finder action.
+runFinderM :: FinderM a -> IO a
+runFinderM = inCache_result <=< runFinderCacheM
+
+instance Functor FinderM where
+ fmap f (FinderM io) = FinderM $ fmap (fmap f) io
+
+instance Applicative FinderM where
+ pure = FinderM . pure . InCache
+ (<*>) = ap
+
+-- | Sequencing of finder computations: the overall computation remains
+-- "in the cache" as long as every individual step completes "in the cache".
+--
+-- After the first cache miss, all residual operations (including further
+-- cache lookups) move into the search action.
+instance Monad FinderM where
+ FinderM io >>= f = FinderM $ io >>= \ case
+ InCache a -> runFinderCacheM (f a)
+ NotInCache go -> pure $ NotInCache $
+ go >>= \ a -> inCache_result =<< runFinderCacheM (f a)
+
+-- | There is no lawful 'MonadIO' instance for 'FinderM': to guarantee that
+-- @liftIO . pure = pure@, 'liftIO' would have to run the action in the
+-- cache-only phase, defeating the guarantee that 'InCache' results involve
+-- no filesystem access.
+--
+-- All I/O in 'FinderM' enters through 'withCacheOrElse'.
+instance
+ Unsatisfiable
+ ( Text "No (lawful) 'MonadIO' instance for 'FinderM'."
+ :$$: Text "Use 'withCacheOrElse' to embed an I/O operation into the search phase of 'FinderM'."
+ )
+ => MonadIO FinderM where
+ liftIO = unsatisfiable
+
+-- | Obtain the result from an 'InCache' value, running the inner search
+-- operation in case of a cache miss.
+inCache_result :: InCache a -> IO a
+inCache_result (InCache a) = pure a
+inCache_result (NotInCache go) = go
+
+-- | Look up an 'InstalledModule' in the finder cache, falling back to the
+-- given search action in case of cache miss (recording its result in the cache).
+withCacheOrElse
+ :: FinderCache
+ -> InstalledModule
+ -> IO InstalledFindResult -- ^ search action (only executed on cache miss)
+ -> FinderM InstalledFindResult
+withCacheOrElse fc mod search = FinderM $ do
+ m <- lookupFinderCache fc mod
+ case m of
+ Just result -> pure $ InCache result
+ Nothing -> pure $ NotInCache $ do
+ result <- search
+ addToFinderCache fc mod result
+ return result
+
-- -----------------------------------------------------------------------------
--External entry points
@@ -180,7 +283,7 @@ getDirHash dir = do
--
-- Handles user-written module imports, @SOURCE@ imports, plugin module imports,
-- system imports, etc.
-resolveImport :: HscEnv -> UnresolvedImport PkgQual -> IO FindResult
+resolveImport :: HscEnv -> UnresolvedImport PkgQual -> FinderM FindResult
resolveImport hsc_env (UnresolvedImport { ui_scope, ui_pkg_qual, ui_boot, ui_mod_name }) = do
res <- findImportedModule hsc_env ui_scope ui_mod_name ui_pkg_qual
case (res, ui_boot) of
@@ -196,7 +299,7 @@ findImportedModule
-- ^ The module name to look up
-> PkgQual
-- ^ Optional PackageImports package name
- -> IO FindResult
+ -> FinderM FindResult
findImportedModule hsc_env scope mod pkg_qual =
let fc = hsc_FC hsc_env
mb_home_unit = hsc_home_unit_maybe hsc_env
@@ -223,7 +326,7 @@ findImportedModuleNoHsc
-> ModuleLookupScope
-> ModuleName
-> PkgQual
- -> IO FindResult
+ -> FinderM FindResult
findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name mb_pkg
| LookupPlugin <- scope
= findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit mod_name
@@ -254,19 +357,19 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit
Nothing -> other_fopts
Just home_unit_id -> (home_unit_id, fopts) : other_fopts
- home_import :: IO FindResult
+ home_import :: FinderM FindResult
home_import = case mb_home_unit of
Just home_unit -> findHomeModule fc fopts home_unit mod_name
Nothing -> pure $
NoPackage (panic "findImportedModule: no home-unit")
- home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult
+ home_pkg_import :: (UnitId, FinderOpts) -> FinderM FindResult
home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name
- pkg_import :: IO FindResult
+ pkg_import :: FinderM FindResult
pkg_import = findExposedPackageModule fc fopts unit_state scope mod_name mb_pkg
- unqual_import :: IO FindResult
+ unqual_import :: FinderM FindResult
unqual_import = findHomeOrRegularPackageModule fc fopts ue
home_module_name_providers_map mb_home_unit scope mod_name
@@ -291,7 +394,7 @@ findPluginModuleNoHsc
-> HomeModuleNameProvidersMap
-> Maybe HomeUnit
-> ModuleName
- -> IO FindResult
+ -> FinderM FindResult
findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name =
findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
mb_home_unit LookupUser mod_name
@@ -303,7 +406,7 @@ findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(J
findPluginModuleNoHsc fc fopts ue _ Nothing mod_name =
findExposedPluginPackageModule fc fopts (ue_homeUnitState ue) mod_name
-findPluginModule :: HscEnv -> ModuleName -> IO FindResult
+findPluginModule :: HscEnv -> ModuleName -> FinderM FindResult
findPluginModule hsc_env mod_name = do
let fc = hsc_FC hsc_env
mb_home_unit = hsc_home_unit_maybe hsc_env
@@ -375,7 +478,7 @@ findHomeUnitDepModule
-> ModuleLookupScope
-> ModuleName
-> (UnitId, FinderOpts)
- -> IO FindResult
+ -> FinderM FindResult
findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name (uid, opts)
-- If the module is reexported, then look for it as if it was from the
-- perspective of the package which reexports it.
@@ -402,7 +505,7 @@ findHomeModuleAmongDeps
-> Maybe HomeUnit
-> ModuleLookupScope
-> ModuleName
- -> IO FindResult
+ -> FinderM FindResult
findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name =
foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts)
-- Do not try to be smart and change this to `foldr orIfNotFound home_import
@@ -433,7 +536,7 @@ findHomeOrRegularPackageModule
-> Maybe HomeUnit
-> ModuleLookupScope
-> ModuleName
- -> IO FindResult
+ -> FinderM FindResult
findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name =
findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
mb_home_unit scope mod_name
@@ -448,7 +551,15 @@ findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_hom
-- | A version of findExactModule which takes the exact parts of the HscEnv it needs
-- directly.
-findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
+findExactModuleNoHsc
+ :: FinderCache
+ -> FinderOpts
+ -> UnitEnvGraph FinderOpts
+ -> UnitState
+ -> Maybe HomeUnit
+ -> InstalledModule
+ -> IsBootInterface
+ -> FinderM InstalledFindResult
findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do
res <- case mb_home_unit of
Just home_unit
@@ -461,13 +572,12 @@ findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot =
(InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc))
_ -> return res
-
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
-- where the files associated with this module live. It is used when
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").
-findExactModule :: HscEnv -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
+findExactModule :: HscEnv -> InstalledModule -> IsBootInterface -> FinderM InstalledFindResult
findExactModule hsc_env mod is_boot = do
let dflags = hsc_dflags hsc_env
let fc = hsc_FC hsc_env
@@ -476,7 +586,6 @@ findExactModule hsc_env mod is_boot = do
let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)
findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot
-
-- -----------------------------------------------------------------------------
-- Helpers
@@ -504,28 +613,17 @@ orIfNotFound this or_this = do
_other -> return res2
_other -> return res
--- | Helper function for 'findHomeModule': this function wraps an IO action
--- which would look up @mod_name@ in the file system (the home package),
--- and first consults the 'hsc_FC' cache to see if the lookup has already
--- been done. Otherwise, do the lookup (with the IO action) and save
--- the result in the finder cache and the module location cache (if it
--- was successful.)
-homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
-homeSearchCache fc home_unit mod_name do_this = do
- let mod = mkModule home_unit mod_name
- modLocationCache fc mod do_this
-
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleLookupScope -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleLookupScope -> ModuleName -> PkgQual -> FinderM FindResult
findExposedPackageModule fc fopts units scope mod_name mb_pkg =
findLookupResult fc fopts
$ lookupModuleWithSuggestions units scope mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> FinderM FindResult
findExposedPluginPackageModule fc fopts units mod_name =
findLookupResult fc fopts
$ lookupPluginModuleWithSuggestions units LookupUser mod_name NoPkgQual
-findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
+findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> FinderM FindResult
findLookupResult fc fopts r = case r of
LookupFound m pkg_conf -> do
let im = fst (getModuleInstantiation m)
@@ -570,16 +668,6 @@ findLookupResult fc fopts r = case r of
, fr_unusables = []
, fr_suggestions = suggest' })
-modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
-modLocationCache fc mod do_this = do
- m <- lookupFinderCache fc mod
- case m of
- Just result -> return result
- Nothing -> do
- result <- do_this
- addToFinderCache fc mod result
- return result
-
addModuleToFinder :: FinderCache -> Module -> ModLocation -> HscSource -> IO ()
addModuleToFinder fc mod loc src_flavour = do
let imod = toUnitId <$> mod
@@ -597,7 +685,7 @@ addHomeModuleToFinder fc home_unit mod_name loc src_flavour = do
-- -----------------------------------------------------------------------------
-- The internal workers
-findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult
+findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> FinderM FindResult
findHomeModule fc fopts home_unit mod_name = do
let uid = homeUnitAsUnit home_unit
r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name
@@ -622,7 +710,7 @@ mkHomeHidden uid =
, fr_unusables = []
, fr_suggestions = []}
-findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult
+findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> FinderM FindResult
findHomePackageModule fc fopts home_unit mod_name = do
let uid = RealUnit (Definite home_unit)
r <- findInstalledHomeModule fc fopts home_unit mod_name
@@ -655,9 +743,9 @@ findHomePackageModule fc fopts home_unit mod_name = do
--
-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to
-- call this.)
-findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO InstalledFindResult
-findInstalledHomeModule fc fopts home_unit mod_name = do
- homeSearchCache fc home_unit mod_name $
+findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> FinderM InstalledFindResult
+findInstalledHomeModule fc fopts home_unit mod_name =
+ withCacheOrElse fc (mkModule home_unit mod_name) $
let
maybe_working_dir = finder_workingDirectory fopts
home_path = case maybe_working_dir of
@@ -701,7 +789,7 @@ augmentImports work_dir (fp:fps)
| otherwise = (work_dir </> fp) : augmentImports work_dir fps
-- | Search for a module in external packages only.
-findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult
+findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> FinderM InstalledFindResult
findPackageModule fc unit_state fopts mod = do
let pkg_id = moduleUnit mod
case lookupUnitId unit_state pkg_id of
@@ -715,11 +803,11 @@ findPackageModule fc unit_state fopts mod = do
-- the 'UnitInfo' must be consistent with the unit id in the 'Module'.
-- The redundancy is to avoid an extra lookup in the package state
-- for the appropriate config.
-findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> IO InstalledFindResult
+findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> FinderM InstalledFindResult
findPackageModule_ fc fopts mod pkg_conf = do
massertPpr (moduleUnit mod == unitId pkg_conf)
(ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))
- modLocationCache fc mod $
+ withCacheOrElse fc mod $
let
tag = waysBuildTag (finder_ways fopts)
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -2378,7 +2378,7 @@ addModule files = do
checkTargetModule :: GhciMonad m => ModuleName -> m Bool
checkTargetModule m = do
hsc_env <- GHC.getSession
- result <- liftIO $
+ result <- liftIO $ Finder.runFinderM $
Finder.findImportedModule hsc_env Finder.LookupUser m NoPkgQual
case result of
Found _ _ -> return True
=====================================
ghc/Main.hs
=====================================
@@ -45,7 +45,7 @@ import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins )
import GHC.Unit.Module ( ModuleName, mkModuleName )
import GHC.Unit.Module.ModIface
import GHC.Unit.State ( pprUnits, pprUnitsSimple )
-import GHC.Unit.Finder ( findImportedModule, FindResult(..) )
+import GHC.Unit.Finder ( findImportedModule, runFinderM, FindResult(..) )
import GHC.Unit.Types ( IsBootInterface(..) )
import GHC.Types.Basic ( failed )
@@ -492,7 +492,7 @@ abiHash strs = do
let find_it str = do
let modname = mkModuleName str
- r <- findImportedModule hsc_env LookupUser modname NoPkgQual
+ r <- runFinderM $ findImportedModule hsc_env LookupUser modname NoPkgQual
case r of
Found _ m -> return m
_error ->
=====================================
linters/lint-codes/LintCodes/Static.hs
=====================================
@@ -67,7 +67,7 @@ import GHC.Types.PkgQual
import GHC.Tc.Utils.Monad
( initIfaceLoad )
import GHC.Unit.Finder
- ( FindResult(..), ModuleLookupScope(..), findImportedModule )
+ ( FindResult(..), ModuleLookupScope(..), findImportedModule, runFinderM )
import GHC.Utils.Outputable
( text )
import Language.Haskell.Syntax.Module.Name
@@ -157,7 +157,7 @@ ghcDiagnosticCodeTyCon mb_libDir =
; liftIO
-- STEP 2: look up the module "GHC.Types.Error.Codes"
- do { res <- findImportedModule hsc_env LookupUser (mkModuleName "GHC.Types.Error.Codes") NoPkgQual
+ do { res <- runFinderM $ findImportedModule hsc_env LookupUser (mkModuleName "GHC.Types.Error.Codes") NoPkgQual
; case res of
{ Found _ modl ->
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -69,7 +69,7 @@ import GHC.Tc.Utils.Monad (initIfaceLoad, initIfaceLcl)
import GHC.Tc.Utils.Env (lookupGlobal_maybe)
import GHC.Types.Error (mkUnknownDiagnostic)
import GHC.Types.Name.Occurrence (emptyOccEnv)
-import GHC.Unit.Finder (findImportedModule, ModuleLookupScope(..), FindResult(Found))
+import GHC.Unit.Finder (findImportedModule, runFinderM, ModuleLookupScope(..), FindResult(Found))
import GHC.Unit.Home.ModInfo
import GHC.Unit.Home.PackageTable
import GHC.Unit.Module.Graph (ModuleGraphNode (..), ModuleNodeInfo(..))
@@ -386,7 +386,7 @@ createOneShotIface verbosity flags instIfaceMap moduleNameStr = do
Nothing -> dflags
-- We should find the module here, otherwise there would have been an error earlier.
- res <- liftIO $ findImportedModule hsc_env LookupUser moduleNm NoPkgQual
+ res <- liftIO $ runFinderM $ findImportedModule hsc_env LookupUser moduleNm NoPkgQual
let hieFilePath = case res of
Found ml _ -> ml_hie_file ml
_ -> throwE "createOneShotIface: module not found"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff3a0fccc254ac4f85aff5e394f60cc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff3a0fccc254ac4f85aff5e394f60cc…
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
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 25 Aug '26
by Marge Bot (＠marge-bot) 25 Aug '26
25 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
dfe4233c by Andreas Klebinger at 2026-08-25T07:37:30-04:00
rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
We accidentally operated over `uint64_t*` when we should use `uint8_t`.
Fixes #27569
- - - - -
3a679c2f by Zubin Duggal at 2026-08-25T07:37:32-04:00
ghc-internal: annotateSTM should use catchSTM# rather than catch#
A catch# frame inside a transaction breaks retry and async exception
delivery.
Fixes #27657
- - - - -
e885a4e5 by Alan Zimmerman at 2026-08-25T07:37:33-04:00
EPA: Uses Parsers.parseModule for exactprint tests
Parsers.parseModule is the advertised way to parse for use for exact
printing in the ghc-exactprint library. This commit updates the GHC
exact print testing to use it.
This requires moving the comment balancing that was occurring
only in the test path into the advertising parser path, so it moves
from Transforms.hs to Utils.hs.
Also update the comment adding to honour trailing annotations
- - - - -
13 changed files:
- + changelog.d/T27657
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- rts/linker/elf_reloc_riscv64.c
- + testsuite/tests/concurrent/should_run/T27657a.hs
- + testsuite/tests/concurrent/should_run/T27657a.stdout
- + testsuite/tests/concurrent/should_run/T27657b.hs
- + testsuite/tests/concurrent/should_run/T27657b.stdout
- testsuite/tests/concurrent/should_run/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
changelog.d/T27657
=====================================
@@ -0,0 +1,9 @@
+section: base
+issues: #27657
+mrs: !16508
+synopsis:
+ Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
+description:
+ ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
+ ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
+ correct way to catch exceptions inside STM.
=====================================
libraries/ghc-internal/src/GHC/Internal/STM.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation)
import GHC.Internal.Exception.Type (WhileHandling(..))
import GHC.Internal.Maybe (Maybe(..))
import GHC.Internal.Prim (
- RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
+ RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
)
import GHC.Internal.Prim.PtrEq (sameTVar#)
@@ -213,7 +213,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
-- | Execute an 'STM' action, adding the given 'ExceptionContext'
-- to any thrown synchronous exceptions.
annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
-annotateSTM ann (STM io) = STM (catch# io handler)
+annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657
where
handler se = raiseIO# (addExceptionContext ann se)
=====================================
rts/linker/elf_reloc_riscv64.c
=====================================
@@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) {
/* The main object code */
void *codeBegin = oc->image + oc->misalignment;
- __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize));
+ __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize));
/* Jump Islands */
__builtin___clear_cache((void *)oc->symbol_extras,
=====================================
testsuite/tests/concurrent/should_run/T27657a.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO
+-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper.
+
+import Control.Exception
+import GHC.Conc
+
+main :: IO ()
+main = do
+ r <- atomically $
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) -> retry)
+ `orElse` pure "T27657a: completed"
+ putStrLn r
=====================================
testsuite/tests/concurrent/should_run/T27657a.stdout
=====================================
@@ -0,0 +1 @@
+T27657a: completed
=====================================
testsuite/tests/concurrent/should_run/T27657b.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- An async exception delivered while a catchSTM handler runs must abort the
+-- transaction, not be swallowed by a restart of the invalidated one.
+
+import Control.Concurrent.MVar
+import Control.Exception
+import GHC.Conc
+
+waitParked :: ThreadId -> IO ()
+waitParked t = do
+ s <- threadStatus t
+ case s of
+ ThreadBlocked BlockedOnMVar -> pure ()
+ _ -> threadDelay 1000 >> waitParked t
+
+main :: IO ()
+main = do
+ tv <- newTVarIO (0 :: Int)
+ park <- newEmptyMVar
+ result <- newEmptyMVar
+ t <- forkIO $ do
+ r <- try $ atomically $ do
+ v <- readTVar tv
+ catchSTM (throwSTM (ErrorCall "boom"))
+ (\(_ :: SomeException) ->
+ if v == 0
+ then do unsafeIOToSTM (takeMVar park)
+ pure "handler resumed"
+ else pure "transaction restarted, exception dropped")
+ putMVar result (r :: Either SomeException String)
+ -- parked in the handler, so t cannot revalidate its trec before delivery
+ waitParked t
+ atomically (writeTVar tv 1)
+ killThread t
+ r <- takeMVar result
+ putStrLn $ case r of
+ Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered"
+ | otherwise -> "T27657b: unexpected exception: " ++ displayException e
+ Right s -> "T27657b: FAILED, " ++ s
=====================================
testsuite/tests/concurrent/should_run/T27657b.stdout
=====================================
@@ -0,0 +1 @@
+T27657b: killThread delivered
=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -340,3 +340,6 @@ test('T27105_fail',
extra_run_opts('+RTS -C0.2 -RTS'), expect_fail,
run_timeout_multiplier(0.05)],
multimod_compile_and_run, ['T27105.hs', ''])
+
+test('T27657a', normal, compile_and_run, [''])
+test('T27657b', normal, compile_and_run, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where
Just exps -> do
let (op,cp,tcs) = am_exports $ anns an0
op' <- markEpToken op
- exps' <- mapM markAnnotated exps
+ exps' <- mapM markAnnotated (filter notIEDoc exps)
tcs' <- mapM markEpToken tcs
cp' <- markEpToken cp
return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}})
=====================================
utils/check-exact/Main.hs
=====================================
@@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Test17519.hs" Nothing
-- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing
-- "../../testsuite/tests/printer/Test19798.hs" Nothing
- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ -- "../../testsuite/tests/printer/Test10309.hs" Nothing
+ "../../testsuite/tests/printer/Haddock1.hs" Nothing
-- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing
-- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing
@@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8
testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO ()
testOneFile _ libdir fileName mchanger = do
- (p,_toks) <- parseOneFile libdir fileName
+ p <- parseOneFile libdir fileName
let
origAst = ppAst p
pped = exactPrint p
@@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do
changedSource <- readFile newFile
return (expectedSource == changedSource, expectedSource, changedSource)
- (p',_) <- parseOneFile libdir newFile
+ p' <- parseOneFile libdir newFile
let newAstStr :: String
newAstStr = ppAst p'
writeBinFile newAstFile newAstStr
@@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do
ppAst :: Data a => a -> String
ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast
-
-parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token])
+parseOneFile :: FilePath -> FilePath -> IO ParsedSource
parseOneFile libdir fileName = do
- res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName
+ res <- Parsers.parseModule libdir fileName
case res of
Left m -> error (internalDebugShowMessages m)
- Right (injectedComments, _dflags, pmod) -> do
- let !pmodWithComments = insertCppComments pmod injectedComments
- return (pmodWithComments, [])
+ Right pmod -> return pmod
-- ---------------------------------------------------------------------
@@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do
- let (oldDecls) = map unWrapValBind bs
- -- let decls = s:d:oldDecls
+ let oldDecls = map unWrapValBind bs
let oldDecls' = captureLineSpacing oldDecls
let (VbSig o:oldBinds) = map wrapValBind oldDecls'
o' = setEntryDP o (DifferentLine 2 0)
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -46,6 +46,7 @@ module Parsers (
) where
import Preprocess
+import Utils
import Data.Functor (void)
@@ -270,7 +271,10 @@ postParseTransform
-> Either a (GHC.ParsedSource)
postParseTransform parseRes = fmap mkAnns parseRes
where
- mkAnns (_cs, _, m) = fixModuleComments m
+ mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs)
+ noIEDoc (GHC.L l m) = case GHC.hsmodExports m of
+ Nothing -> GHC.L l m
+ Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps }
fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource
fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail
import GHC hiding (parseModule, parsedSource)
import GHC.Parser.PostProcess ( wrapValBind )
import GHC.Data.FastString
-import GHC.Types.SrcLoc
import Data.Data
import Data.List (unsnoc)
@@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r)
(a',b') = balanceComments a b
r = balanceCommentsList' (b':ls)
+balanceCommentsListA :: [LocatedA a ] -> [LocatedA a]
+balanceCommentsListA [] = []
+balanceCommentsListA [x] = [x]
+balanceCommentsListA (a:b:ls) = (a':r)
+ where
+ (a',b') = balanceCommentsA a b
+ r = balanceCommentsListA (b':ls)
+
-- |The GHC parser puts all comments appearing between the end of one AST
-- item and the beginning of the next as 'annPriorComments' for the second one.
-- This function takes two adjacent AST items and moves any 'annPriorComments'
@@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt)
(HsValBinds _ vb') -> vb'
_ -> ValBinds noExtField []
-
-balanceCommentsListA :: [LocatedA a] -> [LocatedA a]
-balanceCommentsListA [] = []
-balanceCommentsListA [x] = [x]
-balanceCommentsListA (a:b:ls) = (a':r)
- where
- (a',b') = balanceCommentsA a b
- r = balanceCommentsListA (b':ls)
-
-- |Prior to moving an AST element, make sure any trailing comments belonging to
-- it are attached to it, and not the following element. Of necessity this is a
-- heuristic process, to be tuned later. Possibly a variant should be provided
@@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs)
-- ---------------------------------------------------------------------
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
-splitComments p cs = (before, middle, after)
- where
- cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmpe (L _ _) = True
-
- cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
- cmpb (L _ _) = True
-
- (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
- (before, middle) = break cmpb beforeEnd
-
-
--- | Split comments into ones occurring before the end of the reference
--- span, and those after it.
-splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsEnd p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
--- | Split comments into ones occurring before the start of the reference
--- span, and those after it.
-splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
-splitCommentsStart p (EpaComments cs) = cs'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = case after of
- [] -> EpaComments cs
- _ -> epaCommentsBalanced before after
-splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
- where
- cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
- cmp (L _ _) = True
- (before, after) = break cmp cs
- cs' = before
- ts' = after <> ts
-
moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u)
=> LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u)
moveLeadingComments (L la a) lb = (L la' a, lb')
@@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs)
anchorFromLocatedA :: LocatedA a -> RealSrcSpan
anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc
--- | Get the full span of interest for comments from a LocatedA.
--- This extends up to the last TrailingAnn
-fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
-fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr
- where
- r = epaLocationRealSrcSpan anc
- trailing_loc ta = case ta_location ta of
- EpaSpan (RealSrcSpan s _) -> [s]
- _ -> []
- rr = case reverse (concatMap trailing_loc tas) of
- [] -> r
- (s:_) -> combineRealSrcSpans r s
-
-- ---------------------------------------------------------------------
balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs))
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
(p2, remaining) = insertTopLevelCppComments p1 toplevel
addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
- addCommentsListItem = addComments
+ addCommentsListItem = addCommentsA
addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList)
addCommentsList = addComments
@@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
_ -> return $ EpAnn anc an ocs
+ addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
+ addCommentsA ann@(EpAnn anc an ocs) = do
+ case anc of
+ EpaSpan (RealSrcSpan s _) -> do
+ unAllocated <- get
+ let
+ (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated
+ balanced = splitCommentsEnd s (EpaComments these)
+ cs' = sortEpAnnComments (ocs <> balanced)
+ put rest
+ return $ EpAnn anc an cs'
+
+ _ -> return $ EpAnn anc an ocs
+
workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
workInComments ocs [] = ocs
workInComments ocs new = cs'
@@ -264,9 +278,14 @@ workInComments ocs new = cs'
= break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) )
new
+sortEpAnnComments :: EpAnnComments -> EpAnnComments
+sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs)
+sortEpAnnComments (EpaCommentsBalanced pc fc)
+ = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc)
+
insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment])
insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs
- = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3)
+ = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3)
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs))
-- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs))
where
@@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
cs' = workInComments (comments an1) stay
_ -> (an1,cs0a)
- (mexports', an3, cs1) =
- case mexports of
- Nothing -> (Nothing, an2, cs0b)
- Just exports -> (Just exports', an3', cse)
- where
- (csh', cs0b') = case am_exports $ anns an2 of
- (tokOP, _tokCP, _tokCommas) ->
- case tokOP of
- (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n)
- where
- (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) )
- cs0b
-
- _ -> ([], cs0b)
- hc1' = workInComments (comments an2) csh'
- an3' = an2 { comments = hc1' }
- (exports', cse) = allocPreceding exports cs0b'
- (imports0, cs2) = allocPreceding imports cs1
+ (imports0, cs2) = allocPreceding imports cs0b
(imports', hc0i) = balanceFirstLocatedAComments imports0
(decls0, cs3) = allocPreceding decls cs2
@@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
-- Either hc0i or hc0d should have comments. Combine them
hc0 = hc0i ++ hc0d
- (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0
- hc2 = workInComments (comments an3) hc1
- an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 }
+ (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0
+ hc2 = workInComments (comments an2) hc1
+ an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 }
allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment])
allocPreceding [] cs' = ([], cs')
@@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c)
annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c)
annListBracketsLocs ListNone = (noAnn, noAnn)
-
data SplitWhere = Before | After
splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment])
@@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p'
-- ---------------------------------------------------------------------
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
+fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann
+
+-- | Get the full span of interest for comments from a LocatedA.
+-- This extends up to the last TrailingAnn
+fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan
+fullSpanFromEpAnnA (EpAnn anc tas _) = rr
+ where
+ r = epaLocationRealSrcSpan anc
+ trailing_loc ta = case ta_location ta of
+ EpaSpan (RealSrcSpan s _) -> [s]
+ _ -> []
+ rr = case reverse (concatMap trailing_loc tas) of
+ [] -> r
+ (s:_) -> combineRealSrcSpans r s
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
+splitComments p cs = (before, middle, after)
+ where
+ cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmpe (L _ _) = True
+
+ cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
+ cmpb (L _ _) = True
+
+ (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
+ (before, middle) = break cmpb beforeEnd
+
+
+-- | Split comments into ones occurring before the end of the reference
+-- span, and those after it.
+splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsEnd p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- | Split comments into ones occurring before the start of the reference
+-- span, and those after it.
+splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsStart p (EpaComments cs) = cs'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = case after of
+ [] -> EpaComments cs
+ _ -> epaCommentsBalanced before after
+splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
+ where
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
+ cmp (L _ _) = True
+ (before, after) = break cmp cs
+ cs' = before
+ ts' = after <> ts
+
+-- ---------------------------------------------------------------------
+
ghcCommentText :: LEpaComment -> String
ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s
ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/719b68eb776239bb6ef63a8acb213b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/719b68eb776239bb6ef63a8acb213b…
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
1
0
[Git][ghc/ghc][wip/andreask/arm-ffi] 2 commits: Add some test cases covering bugs in the arm ncg.
by Andreas Klebinger (＠AndreasK) 25 Aug '26
by Andreas Klebinger (＠AndreasK) 25 Aug '26
25 Aug '26
Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC
Commits:
ac157837 by Andreas Klebinger at 2026-08-25T12:53:43+02:00
Add some test cases covering bugs in the arm ncg.
* Test for #27430 (subword ffi results)
* #27537 - subword conversions
* #27538 - subwords used in conditional
* #27533 - single byte read
- - - - -
189a37c2 by Andreas Klebinger at 2026-08-25T12:53:55+02:00
cmmLint: Lint against MO_FS_Truncate subword use.
- - - - -
12 changed files:
- compiler/GHC/Cmm/MachOp.hs
- testsuite/tests/cmm/should_compile/Makefile
- + testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr
- − testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout
- testsuite/tests/cmm/should_compile/all.T
- + testsuite/tests/codeGen/should_run/T27430.stdout
- + testsuite/tests/codeGen/should_run/T27430_c.c
- + testsuite/tests/codeGen/should_run/T27533_cmm.cmm
- + testsuite/tests/codeGen/should_run/T27537.hs
- + testsuite/tests/codeGen/should_run/T27537.stdout
- + testsuite/tests/codeGen/should_run/T27538.stdout
- testsuite/tests/codeGen/should_run/all.T
Changes:
=====================================
compiler/GHC/Cmm/MachOp.hs
=====================================
@@ -623,7 +623,9 @@ machOpArgReps platform op =
MO_XX_Conv from _ -> Just [from]
-- Only supports W32/W64
MO_SF_Round from _w -> onlyW32W64 from
- MO_FS_Truncate from _ -> onlyW32W64 from
+ MO_FS_Truncate from to
+ | to `notElem` [W32, W64] -> Nothing
+ | otherwise -> onlyW32W64 from
MO_FF_Conv from _ -> onlyW32W64 from
MO_WF_Bitcast w -> onlyW32W64 w
MO_FW_Bitcast w -> onlyW32W64 w
=====================================
testsuite/tests/cmm/should_compile/Makefile
=====================================
@@ -16,16 +16,3 @@ T16930:
T23610:
'$(TEST_HC)' $(TEST_HC_OPTS) T23610.cmm -S
-
-# The three seds below, in order:
-# 1. Keep only the "Parsed Cmm" dump, since that is the one stage where the
-# unreachable block still exists.
-# 2. Rewrite goto targets: their label uniques survive -dsuppress-uniques
-# (#21310).
-# 3. Drop the "// CmmAssign"-style node annotations, which pprNode emits
-# only on DEBUG compilers.
-T27368-ppr-debug:
- '$(TEST_HC)' $(TEST_HC_OPTS) -c -no-hs-main -ddump-cmm-verbose-by-proc -dppr-debug -dsuppress-uniques -dsuppress-ticks T27368-ppr-debug.cmm 2>&1 \
- | sed -n '/^==* Parsed Cmm/,/^ \}\]/p' \
- | sed 's/goto c[0-9A-Za-z]*/goto _lbl_/g' \
- | sed 's| *// Cmm[A-Za-z]*$$||'
=====================================
testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr
=====================================
@@ -0,0 +1,191 @@
+
+==================== Parsed Cmm ====================
+[testUnreachable() { // [R1]
+ { info_tbls: []
+ stack_info: arg_space: 8
+ }
+ {offset
+ c7: // global
+ _c1::I64 = R1;
+ //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
+ if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
+ c2: // global
+ //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
+ goto c6;
+ c6: // global
+ //tick src<T27368-ppr-debug.cmm:17:5-12>
+ _c1::I64 = _c1::I64 (-[W64]) 1;
+ R1 = _c1::I64;
+ call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+ c4: // global
+ goto c3;
+ c3: // global
+ R1 = _c1::I64;
+ call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+ // unreachable blocks:
+ c5: // global
+ //tick src<T27368-ppr-debug.cmm:13:5-13>
+ _c1::I64 = _c1::I64 (+[W64]) 42;
+ R1 = _c1::I64;
+ call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+ }
+ }]
+
+
+
+==================== Post control-flow optimisations (1) ====================
+testUnreachable
+{offset
+ c7: // global
+ _c1::I64 = R1;
+ //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
+ if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
+ c2: // global
+ //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
+ //tick src<T27368-ppr-debug.cmm:17:5-12>
+ _c1::I64 = _c1::I64 (-[W64]) 1;
+ R1 = _c1::I64;
+ call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+ c4: // global
+ R1 = _c1::I64;
+ call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+}
+
+
+
+==================== Post switch plan ====================
+testUnreachable
+{offset
+ c7: // global
+ _c1::I64 = R1;
+ //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
+ if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
+ c2: // global
+ //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
+ //tick src<T27368-ppr-debug.cmm:17:5-12>
+ _c1::I64 = _c1::I64 (-[W64]) 1;
+ R1 = _c1::I64;
+ call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+ c4: // global
+ R1 = _c1::I64;
+ call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+}
+
+
+
+==================== ThreadSanitizer instrumentation ====================
+testUnreachable
+{offset
+ c7: // global
+ _c1::I64 = R1;
+ //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
+ if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
+ c2: // global
+ //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
+ //tick src<T27368-ppr-debug.cmm:17:5-12>
+ _c1::I64 = _c1::I64 (-[W64]) 1;
+ R1 = _c1::I64;
+ call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+ c4: // global
+ R1 = _c1::I64;
+ call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+}
+
+
+
+==================== Layout Stack ====================
+testUnreachable
+{offset
+ c7: // global
+ _c1::I64 = R1;
+ //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
+ if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
+ c2: // global
+ //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
+ //tick src<T27368-ppr-debug.cmm:17:5-12>
+ _c1::I64 = _c1::I64 (-[W64]) 1;
+ R1 = _c1::I64;
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
+ c4: // global
+ R1 = _c1::I64;
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
+}
+
+
+
+==================== CAFEnv ====================
+[(c2, {}), (c4, {}), (c7, {})]
+
+
+
+==================== after setInfoTableStackMap ====================
+testUnreachable() { // [R1]
+ { info_tbls: []
+ stack_info: arg_space: 8
+ }
+ {offset
+ c7: // global
+ _c1::I64 = R1;
+ //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
+ if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
+ c2: // global
+ //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
+ //tick src<T27368-ppr-debug.cmm:17:5-12>
+ _c1::I64 = _c1::I64 (-[W64]) 1;
+ R1 = _c1::I64;
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
+ c4: // global
+ R1 = _c1::I64;
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
+ }
+}
+
+
+
+==================== Post control-flow optimisations (2) ====================
+testUnreachable() { // [R1]
+ { info_tbls: []
+ stack_info: arg_space: 8
+ }
+ {offset
+ c7: // global
+ _c1::I64 = R1;
+ //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
+ if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
+ c2: // global
+ //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
+ //tick src<T27368-ppr-debug.cmm:17:5-12>
+ _c1::I64 = _c1::I64 (-[W64]) 1;
+ R1 = _c1::I64;
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
+ c4: // global
+ R1 = _c1::I64;
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
+ }
+}
+
+
+
+==================== Post CPS Cmm ====================
+[testUnreachable() { // [R1]
+ { info_tbls: []
+ stack_info: arg_space: 8
+ }
+ {offset
+ c7: // global
+ _c1::I64 = R1;
+ //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
+ if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
+ c2: // global
+ //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
+ //tick src<T27368-ppr-debug.cmm:17:5-12>
+ _c1::I64 = _c1::I64 (-[W64]) 1;
+ R1 = _c1::I64;
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
+ c4: // global
+ R1 = _c1::I64;
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
+ }
+ }]
+
+
=====================================
testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout deleted
=====================================
@@ -1,27 +0,0 @@
-==================== Parsed Cmm ====================
-[testUnreachable() { // [R1]
- { info_tbls: []
- stack_info: arg_space: 8
- }
- {offset
- _lbl_:
- __locVar_::I64 = R1;
- if (__locVar_::I64 (>[W64]) 0) goto _lbl_; else goto _lbl_;
- _lbl_:
- goto _lbl_;
- _lbl_:
- __locVar_::I64 = __locVar_::I64 (-[W64]) 1;
- R1 = __locVar_::I64;
- call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
- _lbl_:
- goto _lbl_;
- _lbl_:
- R1 = __locVar_::I64;
- call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
- // unreachable blocks:
- _lbl_:
- __locVar_::I64 = __locVar_::I64 (+[W64]) 42;
- R1 = __locVar_::I64;
- call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
- }
- }]
=====================================
testsuite/tests/cmm/should_compile/all.T
=====================================
@@ -13,11 +13,9 @@ test('T20725', normal, compile, ['-package ghc'])
test('T23610', normal, makefile_test, ['T23610'])
test('T24224', [cmm_src, grep_errmsg(r'(F64.*);', [1]), only_ways(['normal'])], compile, ['-no-hs-main -ddump-cmm -dsuppress-all -dsuppress-uniques'])
test('T24474', cmm_src, compile, ['-optc-g3'])
-# -dppr-debug makes stored-but-unreachable blocks visible in Cmm dumps (#27368).
-# Skipped on wordsize(32) targets, where the dump would say I32/P32, and on
-# unregisterised builds, which print call targets with an extra load.
-test('T27368-ppr-debug', [when(wordsize(32), skip), when(unregisterised(), skip)],
- makefile_test, ['T27368-ppr-debug'])
+# Grep for a `... = + .. 42 ..;` occurence from within the dead code block in the cmm dump output.
+test('T27368-ppr-debug', [cmm_src, only_ways(['normal']), grep_errmsg(r'\=.*\+.*(42;)', [1])],
+ compile, ['-no-hs-main -ddump-cmm-verbose-by-proc -dppr-debug'])
test('T24474-cmm-gets-c-opts', cmm_src, compile, ['-optc-DFOO'])
test('T24474-cmm-opt-order', cmm_src, compile, ['-optc-DFOO '
'-optCmmP-UFOO '
=====================================
testsuite/tests/codeGen/should_run/T27430.stdout
=====================================
@@ -0,0 +1,6 @@
+1
+1
+1
+1
+1
+1
=====================================
testsuite/tests/codeGen/should_run/T27430_c.c
=====================================
@@ -0,0 +1,5 @@
+#include <stdint.h>
+
+uint8_t u64_to_u8(uint64_t v) { return (uint8_t)v; }
+uint16_t u64_to_u16(uint64_t v) { return (uint16_t)v; }
+uint32_t u64_to_u32(uint64_t v) { return (uint32_t)v; }
=====================================
testsuite/tests/codeGen/should_run/T27533_cmm.cmm
=====================================
@@ -0,0 +1,14 @@
+#include "Cmm.h"
+
+// Release-store one byte at p. Must touch exactly 1 byte.
+store8 (W_ p) {
+ %release I8[p] = 67 :: I8;
+ return (0);
+}
+
+// Acquire-load one byte from p.
+load8 (W_ p) {
+ I8 v;
+ v = %acquire I8[p];
+ return (TO_ZXW_(v));
+}
=====================================
testsuite/tests/codeGen/should_run/T27537.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts
+
+{-# NOINLINE lt8 #-}
+lt8 :: Int -> Word -> Int -- ltWord8# 254 255: must be 1
+lt8 (I# m) (W# n) = I# (ltWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n))
+
+{-# NOINLINE eq8 #-}
+eq8 :: Int -> Word -> Int -- eqWord8# 254 254: must be 1
+eq8 (I# m) (W# n) = I# (eqWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n))
+
+{-# NOINLINE eqi16 #-}
+eqi16 :: Int -> Int -> Int -- eqInt16# (-2) (-2): must be 1
+eqi16 (I# m) (I# n) = I# (eqInt16# (intToInt16# m) (word16ToInt16# (wordToWord16# (int2Word# n))))
+
+{-# NOINLINE rem8 #-}
+rem8 :: Int -> Word -> Word -- remWord8# 254 100: must be 54
+rem8 (I# m) (W# n) = W# (word8ToWord# (remWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)))
+
+main :: IO ()
+main = do
+ print (lt8 (-2) 255)
+ print (eq8 (-2) 254)
+ print (eqi16 (-2) 65534)
+ print (rem8 (-2) 100)
=====================================
testsuite/tests/codeGen/should_run/T27537.stdout
=====================================
@@ -0,0 +1,4 @@
+1
+1
+1
+54
=====================================
testsuite/tests/codeGen/should_run/T27538.stdout
=====================================
@@ -0,0 +1 @@
+f(0x80) = 0
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -295,3 +295,12 @@ test('aarch64-sxtw-run',
when(unregisterised(), skip)],
multi_compile_and_run,
['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O'])
+
+test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c'])
+
+test('T27533', [req_cmm, extra_ways(['optasm'])], multi_compile_and_run,
+ ['T27533', [('T27533_cmm.cmm', '')], '-O'])
+
+test('T27537', normal, compile_and_run, ['-O'])
+
+test('T27538', normal, compile_and_run, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/293cfa2ec57063f55134f5981be835…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/293cfa2ec57063f55134f5981be835…
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
1
0
[Git][ghc/ghc][wip/romes/27514] Rule-based downsweep with structured concurrency
by sheaf (＠sheaf) 25 Aug '26
by sheaf (＠sheaf) 25 Aug '26
25 Aug '26
sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC
Commits:
a7f99bff by sheaf at 2026-08-25T12:19:36+02:00
Rule-based downsweep with structured concurrency
- - - - -
38 changed files:
- compiler/GHC/Builtin.hs
- + compiler/GHC/Data/Dependent.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Concurrency.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeAction.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/MakeSem.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/UnresolvedImport.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/Types.hs
- + compiler/GHC/Utils/Concurrent/Scope.hs
- compiler/GHC/Utils/TmpFs.hs
- compiler/ghc.cabal.in
- testsuite/tests/diagnostic-codes/codes.stdout
- testsuite/tests/driver/T27461/Makefile
- + testsuite/tests/driver/T27461/T27461c.stderr
- testsuite/tests/driver/T27461/all.T
- + testsuite/tests/driver/T27461/src/Wrong.hs
- testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs
- testsuite/tests/ghc-api/downsweep/OldModLocation.hs
- testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
- testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
- testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs
- testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
- testsuite/tests/splice-imports/SI35.hs
- utils/check-ppr/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a7f99bfff11bf5a0fcfe2c6def79e3c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a7f99bfff11bf5a0fcfe2c6def79e3c…
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
1
0