[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26
by Marge Bot (＠marge-bot) 24 Aug '26
24 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
3d44d11a by Andreas Klebinger at 2026-08-24T06:14: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
- - - - -
16b7cd22 by Alan Zimmerman at 2026-08-24T06:14:31-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
- - - - -
6 changed files:
- rts/linker/elf_reloc_riscv64.c
- 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:
=====================================
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,
=====================================
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/7e4eb741cd5a14d45f6751ad442de1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7e4eb741cd5a14d45f6751ad442de1…
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/sjakobi/T27628-rebox-warning] 14 commits: SpecConstr: Don't warn about reboxing nullary constructors
by Simon Jakobi (＠sjakobi) 24 Aug '26
by Simon Jakobi (＠sjakobi) 24 Aug '26
24 Aug '26
Simon Jakobi pushed to branch wip/sjakobi/T27628-rebox-warning at Glasgow Haskell Compiler / GHC
Commits:
903a0046 by Simon Jakobi at 2026-08-22T14:12:01+02:00
SpecConstr: Don't warn about reboxing nullary constructors
"Reboxing" a nullary constructor just references its shared static
closure: it costs no allocation and even preserves pointer identity.
Such patterns are common (Nil, [], Nothing, ...) and accounted for a
fair share of the -Wspec-constr-reboxing warnings when compiling
containers, e.g. from functions matching an empty-set argument.
See Note [Reboxing warning].
Assisted-by: Claude Fable 5
- - - - -
523a633a by Simon Jakobi at 2026-08-22T14:17:27+02:00
SpecConstr: Attribute reboxing warnings to the enclosing binder
-Wspec-constr-reboxing frequently fires on local functions — join
points and local workers — whose names are meaningless to the user and
which often have no source location at all, e.g.
$j_sahl (Present) Defined at <no location info>
Track the enclosing top-level binder in ScEnv (sc_top_fn) and name it
in the warning, pointing at its definition site: that is where any
remedy would be applied. See Note [Reboxing warning].
Assisted-by: Claude Fable 5
- - - - -
16f32940 by Simon Jakobi at 2026-08-22T14:25:01+02:00
SpecConstr: Emit one reboxing warning per function
Emit -Wspec-constr-reboxing as one diagnostic per specialised
function, merging the reboxed constructors of all its call patterns,
instead of a single module-wide list. Compiling containers produced
several near-identical entries per function (one per call pattern),
e.g. four times `$wgo (Collision)`.
The shorter per-function message points at the users guide for the
possible remedies instead of spelling them out each time.
Also: document the nullary-constructor exemption and the attribution
of local functions in the users guide.
Assisted-by: Claude Fable 5
- - - - -
b01adcd0 by Simon Jakobi at 2026-08-22T14:28:11+02:00
SpecConstr: Merge reboxing warnings that would render identically
Distinct local functions frequently share an occurrence name and
enclosing binder (e.g. two workers both called merge0 inside
IntMap.unionWithKey, from different unfoldings of the same source
function), producing warnings that differ only in their Name's
unique and so print as exact duplicates. Key the per-function
aggregation on (occurrence name, parent) instead of the Name.
Assisted-by: Claude Fable 5
- - - - -
96b4e968 by Simon Jakobi at 2026-08-22T15:08:14+02:00
SetLevels: Preserve source spans on floated poly_ bindings
When the float-out pass lifts a local function past type-variable
bindings, newPolyBndrs made the new poly_ binder with mkSysLocal,
dropping the original binder's source span. Diagnostics naming such
bindings — e.g. -Wspec-constr-reboxing (#27628) — could then only
report "defined at <no location info>".
Keep the original span on the poly_ binder instead. Worker/wrapper
derives worker names with mkDerivedInternalName, so $wpoly_ bindings
inherit the span for free.
The new test T27628g checks that a reboxing warning about a floated
local function points at its definition site.
Assisted-by: Claude Fable 5
- - - - -
c2318213 by Simon Jakobi at 2026-08-22T15:24:25+02:00
SpecConstr: Point reboxing warnings at the local function's definition
A reboxing warning about a local function showed the enclosing
top-level binder's location, so distinct same-named locals rendered
identically and were merged into one warning. Applying a remedy to one
of them then left the warning seemingly unchanged, with no hint that
progress had been made.
Show the local function's own definition site instead, falling back to
the parent's only when the local has none (e.g. simplifier-made join
points). Merging now only affects warnings that point at the same
site, which a single source-level remedy addresses together; see
Note [Reboxing warning].
Assisted-by: Claude Fable 5
- - - - -
35025093 by Simon Jakobi at 2026-08-23T04:14:09+02:00
SpecConstr: Explain reboxing warnings that have no source location
A stage-2 GHC build showed 387 of 499 reboxing warnings pointing at
"<no location info>": local loops (e.g. foldr's go, Data.Map's fromList
stack machinery) that reach the consuming module in interface
unfoldings, which record no spans for local binders. Rendering an
unhelpful span reads like a bug and gives the user nothing to act on.
Instead say "inlined from another module; no source location", and show
constructors imported from other modules qualified with their defining
module — with the function anonymous, they are what identifies the
package to report the reboxing to.
Also quote the function, parent, and constructor names, matching the
usual diagnostic style.
See the new bullet in Note [Reboxing warning].
Context: #27628.
Assisted-by: Claude Fable 5
- - - - -
92115070 by Simon Jakobi at 2026-08-23T04:22:42+02:00
SpecConstr: Merge indistinguishable reboxing warnings uniformly
Reboxing warnings that would render identically were merged only when a
parent attribution was present. Parentless warnings were compared by
Name instead. For located top-level functions the two rules agree,
since distinct functions differ in name or location, but span-less
loops from imported unfoldings all render as e.g.
SpecConstr specialised 'go1' (inlined from another module; ...)
and were still printed once per copy: a stage-2 GHC build had 67 such
go1 lines, 10 of them in a single module. The reader cannot tell the
copies apart, and none of them can be located, so repetition carries no
information. Drop the special case and merge on render identity
throughout, combining the constructor lists of merged warnings.
New test T27628i checks that two span-less same-named loops produce a
single warning listing both reboxed constructors.
Context: #27628.
Assisted-by: Claude Fable 5
- - - - -
47e5dc94 by Simon Jakobi at 2026-08-23T13:34:21+02:00
SpecConstr: Show the specialised function's type in reboxing warnings
A reboxing warning about a span-less loop inlined from another module
identifies it only by a meaningless name like go1. The type is usually
short and is the best available clue to what the function does, so
print it after the name.
The type also joins the render-identity merge key, so same-named
span-less loops of different types no longer collapse into one warning.
See Note [Reboxing warning].
T27628i gains a third source function whose loop matches the first
one's rendering, keeping the merge of indistinguishable warnings
exercised.
Context: #27628.
Assisted-by: Claude Fable 5
- - - - -
8d2e130b by Simon Jakobi at 2026-08-23T13:39:46+02:00
SpecConstr: Name the calling functions in span-less reboxing warnings
A reboxing warning about a function inlined from another module can
point at no located code at all. The call sites that drove the
specialisation can: they sit in top-level binders of the module being
compiled, and following the inlining from one of them identifies the
reboxed loop. Record the enclosing top-level binder of each call
(sc_top_fn) in Call, thread it through CallPat, and render it as
"called from". See Note [Reboxing warning].
Context: #27628.
Assisted-by: Claude Fable 5
- - - - -
c817c224 by Simon Jakobi at 2026-08-23T23:06:52+02:00
Render the reboxing warning as a labelled fact block
The prose rendering packed definition site, callers, and constructors
into one parenthesised run-on that grew hard to scan, especially with
several callers or constructors. Instead show one labelled fact per
line (source, called from, reboxed constructors), values aligned, with
the wrapped-up prose reduced to a closing sentence whose grammar tracks
the constructor count. The printed forall is suppressed (pprSigmaType)
and callers are now always shown, including the enclosing binder of a
local function: as a separate labelled fact it no longer reads as a
duplicate of the source line.
Since the constructor list is now part of what the reader sees per
warning, it joins the render-identical merge key. Same-function
warnings still merge unconditionally, in a separate pass keyed on the
function's Name.
Part of #27628.
Assisted-by: Claude Fable 5
- - - - -
bbc2f3f9 by Simon Jakobi at 2026-08-23T23:14:48+02:00
Classify the specialised function's recursivity in reboxing warnings
A "recursivity:" fact says whether the function SpecConstr specialised
is self-recursive, mutually recursive (naming the other functions of
its Rec group), or non-recursive (e.g. a join point), as bound in the
post-optimisation program. Where the warning fires on code the reader
never wrote in that shape — floated-out loops, span-less inlined
copies — this narrows down what to look for at the source.
The classification falls out of the specialisation entry points:
specRec knows the Rec group (a singleton is genuinely self-recursive,
since the occurrence analyser demotes non-recursive singletons to
NonRec), and specNonRec handles nested non-recursive bindings. See
Note [Reboxing warning].
Part of #27628.
Assisted-by: Claude Fable 5
- - - - -
f0337cb7 by Simon Jakobi at 2026-08-24T01:51:48+02:00
Show the call patterns in reboxing warnings
A reboxing warning used to list the reboxed constructors of all the
function's specialisations as one flat set, which erased the structure
that makes such a list intelligible: constructors from alternative
patterns of one argument, and constructors nested inside others, read
as an unrelated jumble. Now each call pattern is shown as the
constructor skeletons of its arguments, e.g.
call patterns: go (A _) (I# _) (reboxing ‘A’)
go (B _) (I# _) (reboxing ‘B’)
which also pictures what SpecConstr did: it copied the function for
calls of exactly that shape. See Note [Reboxing warning].
Also fix the per-function aggregation, which keyed on the function's
Name alone: two top-level bindings can bind distinct locals sharing a
unique (copies of one inlined unfolding template), and their warnings
were fused, dropping one warning's type and doubling the callers. The
key now includes the enclosing top-level binder. T27628l pins the
fixed behaviour with the Max/Min pair that exposed this.
Part of #27628.
Assisted-by: Claude Fable 5
- - - - -
147702b0 by Simon Jakobi at 2026-08-24T02:54:10+02:00
Render the reboxing tag as a comment, not parens
Parenthesized as (reboxing 'A'), the tag read as one more argument of
the call pattern. A comment can't be part of a call, and GHC already
annotates output this way (:info's "-- Defined in"):
call patterns: go (A _) (I# _) -- reboxes 'A'
go (B _) (I# _) -- reboxes 'B'
Part of #27628.
Assisted-by: Claude Fable 5
- - - - -
23 changed files:
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- docs/users_guide/using-warnings.rst
- testsuite/tests/simplCore/should_compile/T27628.stderr
- testsuite/tests/simplCore/should_compile/T27628b.stderr
- + testsuite/tests/simplCore/should_compile/T27628e.hs
- + testsuite/tests/simplCore/should_compile/T27628f.hs
- + testsuite/tests/simplCore/should_compile/T27628f.stderr
- + testsuite/tests/simplCore/should_compile/T27628g.hs
- + testsuite/tests/simplCore/should_compile/T27628g.stderr
- + testsuite/tests/simplCore/should_compile/T27628h.hs
- + testsuite/tests/simplCore/should_compile/T27628h.stderr
- + testsuite/tests/simplCore/should_compile/T27628h_M.hs
- + testsuite/tests/simplCore/should_compile/T27628i.hs
- + testsuite/tests/simplCore/should_compile/T27628i.stderr
- + testsuite/tests/simplCore/should_compile/T27628i_M.hs
- + testsuite/tests/simplCore/should_compile/T27628j.hs
- + testsuite/tests/simplCore/should_compile/T27628j.stderr
- + testsuite/tests/simplCore/should_compile/T27628k.hs
- + testsuite/tests/simplCore/should_compile/T27628k.stderr
- + testsuite/tests/simplCore/should_compile/T27628l.hs
- + testsuite/tests/simplCore/should_compile/T27628l.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -108,8 +108,8 @@ import GHC.Types.Var.Env
import GHC.Types.Literal ( litIsTrivial )
import GHC.Types.Demand ( DmdSig, prependArgsDmdSig )
import GHC.Types.Cpr ( CprSig, prependArgsCprSig )
-import GHC.Types.Name ( getOccName )
-import GHC.Types.Name.Occurrence ( occNameFS )
+import GHC.Types.Name ( getOccName, getSrcSpan, mkSystemNameAt )
+import GHC.Types.Name.Occurrence ( occNameFS, mkVarOccFS )
import GHC.Types.Unique ( hasKey )
import GHC.Types.Tickish ( tickishIsCode )
import GHC.Types.Unique.Supply
@@ -1872,7 +1872,10 @@ newPolyBndrs dest_lvl
mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id
transfer_join_info bndr $
- mkSysLocal str uniq (idMult bndr) poly_ty
+ -- Keep bndr's srcspan so that diagnostics can
+ -- still point at the original definition
+ mkLocalId (mkSystemNameAt uniq (mkVarOccFS str) (getSrcSpan bndr))
+ (idMult bndr) poly_ty
where
str = fsLit "poly_" `appendFS` occNameFS (getOccName bndr)
poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr))
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -36,6 +36,9 @@ import GHC.Core.Coercion hiding( substCo )
import GHC.Core.Rules
import GHC.Core.Predicate ( scopedSort, typeDeterminesValue )
import GHC.Core.Type hiding ( substTy )
+import GHC.Core.TyCo.Compare ( eqType )
+import GHC.Core.TyCo.Ppr ( pprSigmaType )
+import GHC.Core.TyCo.Tidy ( tidyTopType )
import GHC.Core.TyCon (TyCon, tyConName )
import GHC.Core.Multiplicity
import GHC.Core.Ppr ( pprParendExpr )
@@ -45,12 +48,13 @@ import GHC.Unit.Module.ModGuts
import GHC.Types.InlinePragma
import GHC.Types.Error (DiagnosticReason(..))
-import GHC.Types.Literal ( litIsLifted )
+import GHC.Types.Literal ( Literal, litIsLifted )
import GHC.Types.Id
import GHC.Types.Id.Info ( IdDetails(..) )
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
+import GHC.Types.SrcLoc ( isGoodSrcSpan )
import GHC.Types.Tickish
import GHC.Types.Basic
import GHC.Types.Demand
@@ -75,7 +79,7 @@ import GHC.Exts( SpecConstrAnnotation(..) )
import GHC.Serialized ( deserializeWithData )
import Control.Monad
-import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL, nub, unzip4 )
+import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL, nub, nubBy, unzip4 )
import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Maybe( mapMaybe )
import Data.Ord( comparing )
@@ -790,8 +794,8 @@ specConstrProgram guts
is_rebox _ = False
; when (not (null forced_ws)) $ diagnostic WarningWithoutFlag (forced_msg forced_ws)
- ; when (not (null rebox_ws)) $ diagnostic (WarningWithFlag Opt_WarnSpecConstrReboxing)
- (rebox_msg (nub rebox_ws))
+ ; mapM_ (diagnostic (WarningWithFlag Opt_WarnSpecConstrReboxing) . rebox_msg)
+ (aggregateRebox rebox_ws)
; return (guts { mg_binds = binds' }) }
@@ -802,15 +806,137 @@ specConstrProgram guts
nest 2 (vcat (map ppr warnings)) $$
(text "If this is expected you might want to increase -fmax-forced-spec-args to force specialization anyway.")
+ -- One warning per specialised function (all its patterns listed),
+ -- then warnings that would render identically merged too; see
+ -- Note [Reboxing warning]
+ aggregateRebox :: SpecConstrWarnings -> SpecConstrWarnings
+ aggregateRebox = mergeBy same_render . mergeBy same_fn
+ where
+ mergeBy eq ws
+ = [ SpecReboxed fn ty parent recur (nubBy same_pat (concat patss)) (nub (concat callerss))
+ | w@(SpecReboxed fn ty parent recur _ _) <- nubBy eq ws
+ , let (patss, callerss) = unzip [ (pats, callers)
+ | w'@(SpecReboxed _ _ _ _ pats callers) <- ws
+ , eq w w' ] ]
+
+ -- Also compare the parents: the fn Name alone is ambiguous
+ -- between top-level bindings; see Note [Reboxing warning]
+ same_fn (SpecReboxed fn1 _ p1 _ _ _) (SpecReboxed fn2 _ p2 _ _ _)
+ = fn1 == fn2 && p1 == p2
+ same_fn _ _ = False
+
+ -- Merge warnings that would render identically: same occurrence
+ -- name, type, parent, displayed location, recursivity, and
+ -- patterns. The reader could not tell them apart, so printing
+ -- both is noise; see Note [Reboxing warning]. Callers are
+ -- aggregated, not compared.
+ same_render (SpecReboxed fn1 ty1 p1 r1 pats1 _) (SpecReboxed fn2 ty2 p2 r2 pats2 _)
+ = getOccName fn1 == getOccName fn2 && p1 == p2
+ && nameSrcSpan (rebox_loc_name fn1 p1) == nameSrcSpan (rebox_loc_name fn2 p2)
+ && ty1 `eqType` ty2
+ && r1 `same_recur` r2
+ && equalLength pats1 pats2
+ && and (zipWith same_pat (sortBy cmpReboxedPat pats1)
+ (sortBy cmpReboxedPat pats2))
+ same_render _ _ = False
+
+ same_pat p1 p2 = cmpReboxedPat p1 p2 == EQ
+
+ -- Recursivity as displayed: siblings compare by occurrence name,
+ -- so span-less copies of one mutual group still merge
+ same_recur ReboxSelfRec ReboxSelfRec = True
+ same_recur (ReboxNonRec j1) (ReboxNonRec j2) = j1 == j2
+ same_recur (ReboxMutualRec s1) (ReboxMutualRec s2)
+ = map getOccName (sortBy stableNameCmp s1)
+ == map getOccName (sortBy stableNameCmp s2)
+ same_recur _ _ = False
+
+ -- The definition site shown in a reboxing warning: the fn's own when
+ -- known, otherwise the parent's (e.g. for simplifier-made join points)
+ rebox_loc_name :: Name -> Maybe Name -> Name
+ rebox_loc_name fn (Just parent)
+ | not (isGoodSrcSpan (nameSrcSpan fn)) = parent
+ rebox_loc_name fn _ = fn
+
-- See Note [Reboxing warning]
- rebox_msg :: SpecConstrWarnings -> SDoc
- rebox_msg warnings = text "SpecConstr specialised the following function(s) on a constructor argument that is also used boxed:" $$
- nest 2 (vcat (map ppr warnings)) $$
- text "The specialised code allocates a fresh constructor at each such use (\"reboxing\")," $$
- text "which can increase allocation and defeat pointer-equality-based sharing." $$
- text "Possible remedies: exclude the type with an {-# ANN type T NoSpecConstr #-} pragma," $$
- text "hide the constructor from SpecConstr by wrapping the call-site argument in GHC.Exts.lazy," $$
- text "or use -fno-spec-constr."
+ rebox_msg :: SpecConstrWarning -> SDoc
+ rebox_msg w@(SpecFailForcedArgCount {}) = pprPanic "rebox_msg" (ppr w)
+ rebox_msg (SpecReboxed fn ty mb_parent recur pats callers)
+ = vcat [ hang (text "SpecConstr specialised") 2
+ (quotes (ppr fn <+> dcolon <+> pp_ty))
+ , nest 2 $ vcat $ catMaybes
+ [ Just (fact "source:" pp_source)
+ , Just (fact "recursivity:" pp_recur)
+ , fact "called from:" <$> pp_callers
+ , Just (fact pats_label pp_pats) ]
+ , pp_trailer
+ , text "See -Wspec-constr-reboxing in the users guide for possible remedies." ]
+ where
+ -- Aligned label column; $$ overlaps, so a multi-line value keeps
+ -- its lines aligned under the first
+ fact l v = text l $$ nest 23 v
+
+ -- Truncate only pathologically large types
+ pp_ty = sdocWithContext $ \ctx ->
+ case splitAt 10000 (showSDocOneLine ctx pp_tidy) of
+ (_, []) -> pp_tidy
+ (prefix, _) -> text prefix <> text "..."
+ where pp_tidy = pprSigmaType (tidyTopType ty)
+ -- pprSigmaType: suppress the printed forall
+
+ -- A name with no source span reached this module in an interface
+ -- unfolding: iface files record no spans for local binders
+ pp_source = case (mb_parent, isGoodSrcSpan (nameSrcSpan loc_name)) of
+ (Nothing, True) -> pp_loc
+ (Just p, True) -> quotes (ppr p) <+> text "at" <+> pp_loc
+ (Just p, False) -> quotes (ppr p) <> comma <+> pp_no_loc
+ (Nothing, False) -> pp_no_loc
+ where
+ loc_name = rebox_loc_name fn mb_parent
+ pp_loc = ppr (nameSrcLoc loc_name)
+ pp_no_loc = text "inlined from another module (no source location)"
+
+ pp_recur = case recur of
+ ReboxSelfRec -> text "self-recursive"
+ ReboxNonRec True -> text "non-recursive (a join point)"
+ ReboxNonRec False -> text "non-recursive"
+ ReboxMutualRec sibs
+ -> text "mutually recursive with"
+ <+> pprWithCommas (quotes . ppr) named <> pp_rest
+ where
+ (named, rest) = splitAt 3 (sortBy stableNameCmp sibs)
+ pp_rest = case length rest of
+ 0 -> empty
+ 1 -> text " and 1 other"
+ n -> text " and" <+> int n <+> text "others"
+
+ pp_callers = case sortBy stableNameCmp callers of
+ [] -> Nothing
+ cs -> Just (pprWithCommas (quotes . ppr) cs)
+
+ pats_label = case pats of
+ [_] -> "call pattern:"
+ _ -> "call patterns:"
+
+ pp_pats = vcat (map pp_pat (sortBy cmpReboxedPat pats))
+
+ pp_pat (ReboxedPat shapes cons)
+ = hang (hang (ppr fn) 2 (fsep (map pprPatShape shapes))) 2
+ (text "-- reboxes" <+>
+ pprWithCommas pp_con (sortBy stableNameCmp cons))
+
+ -- Qualify imported constructors: they identify the package to
+ -- follow up with when the function itself has no location
+ pp_con con
+ | Just m <- nameModule_maybe con, m /= mg_module guts
+ = quotes (ppr m <> dot <> ppr con)
+ | otherwise = quotes (ppr con)
+
+ all_cons = nub [ con | ReboxedPat _ cons <- pats, con <- cons ]
+
+ pp_trailer = fsep $ map text $ words $ case all_cons of
+ [_] -> "This constructor argument is also used boxed, so the specialisation may increase allocation and defeat pointer-equality-based sharing."
+ _ -> "These constructor arguments are also used boxed, so the specialisations may increase allocation and defeat pointer-equality-based sharing."
scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecConstrWarning])
scTopBinds _env [] = return (nullUsage, [], [])
scTopBinds env (b:bs) = do { (usg, b', bs', warnings) <- scBind TopLevel env b $
@@ -975,7 +1101,12 @@ data ScEnv = SCE { sc_opts :: !SpecConstrOpts,
-- Domain is OutIds (*after* applying the substitution)
-- Used even for top-level bindings (but not imported ones)
- sc_annotations :: UniqFM Name SpecConstrAnnotation
+ sc_annotations :: UniqFM Name SpecConstrAnnotation,
+
+ sc_top_fn :: Maybe Name
+ -- The top-level binder whose RHS we are inside,
+ -- used to attribute warnings about local functions
+ -- See Note [Reboxing warning]
}
---------------------
@@ -1025,7 +1156,8 @@ initScEnv guts
sc_subst = init_subst,
sc_how_bound = emptyVarEnv,
sc_vals = emptyVarEnv,
- sc_annotations = anns }) }
+ sc_annotations = anns,
+ sc_top_fn = Nothing }) }
where
init_subst = mkEmptySubst $ mkInScopeSetBndrs (mg_binds guts)
-- Acccount for top-level bindings that are not in dependency order;
@@ -1046,6 +1178,11 @@ instance Outputable HowBound where
scForce :: ScEnv -> Bool -> ScEnv
scForce env b = env { sc_force = b }
+-- Keeps the outermost binder; see Note [Reboxing warning]
+setTopFn :: ScEnv -> OutId -> ScEnv
+setTopFn env@(SCE { sc_top_fn = Nothing }) bndr = env { sc_top_fn = Just (idName bndr) }
+setTopFn env _ = env
+
lookupHowBound :: ScEnv -> OutId -> Maybe HowBound
lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
@@ -1286,9 +1423,11 @@ data ScUsage
} -- The domain is OutIds
type CallEnv = IdEnv [Call] -- Domain is OutIds
-data Call = Call OutId [CoreArg] ValueEnv
+data Call = Call OutId [CoreArg] ValueEnv (Maybe Name)
-- The arguments of the call, together with the
-- env giving the constructor bindings at the call site
+ -- and the enclosing top-level binder of the call site
+ -- (sc_top_fn, for reboxing warnings)
-- We keep the function mainly for debug output
--
-- The call is not necessarily saturated; we just put
@@ -1300,7 +1439,7 @@ instance Outputable ScUsage where
, text "occs =" <+> ppr occs ])
instance Outputable Call where
- ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)
+ ppr (Call fn args _ _) = ppr fn <+> fsep (map pprParendExpr args)
nullUsage :: ScUsage
nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
@@ -1443,6 +1582,73 @@ that decision bites, without changing which specialisations are made:
SpecReboxed warnings, which specConstrProgram emits under
-Wspec-constr-reboxing (off by default).
+* One warning per function, listing each call pattern the function was
+ specialised for — the constructor skeletons of the call's arguments,
+ e.g. `go (_ : _) (BMap _) -- reboxes ‘BMap’` — alongside that
+ pattern's reboxed constructors. The shapes show where in the
+ argument each reboxed constructor sits, and picture what SpecConstr
+ did: it made a copy of
+ the function for calls of exactly that shape. The warning also shows
+ the function's type: names like `go1` say nothing, and for span-less
+ functions (last bullet below) the type is the main identifying clue.
+
+ "Per function" means per (parent, function) *pair*: the function's
+ Name alone is ambiguous, because distinct top-level bindings can bind
+ distinct locals that share a unique. That happens when several
+ bindings inline one stable unfolding (e.g. a class's default-method
+ template): each copy keeps the template's uniques, and the simplifier
+ only freshens a binder on an in-scope clash, which cannot arise
+ between sibling top-level RHSs.
+
+ Warnings that would render identically — same name, type, parent,
+ definition site, recursivity, and patterns — are merged too: the
+ reader could not tell them apart, so printing both is noise. For
+ located functions the merged warnings are simplifier-made copies of one
+ binding, addressed by a single source-level remedy; span-less loops
+ inlined from other modules can in principle merge across different
+ origins, but sharing name and type they are almost certainly copies of
+ one function.
+
+* The warning classifies how the specialised function recurses
+ ("recursivity"), taken from the binding SpecConstr saw: a Rec group of
+ one is self-recursive (the occurrence analyser demotes non-recursive
+ singletons to NonRec), a larger group is mutually recursive and the
+ siblings are named, and a nested NonRec binding — typically a join
+ point, see Note [Specialising local let bindings] — is non-recursive.
+ This reflects the post-optimisation program, whose shape can differ
+ from the source's.
+
+* Nullary constructors are exempt: "reboxing" a nullary constructor just
+ references its shared static closure, so it costs no allocation and even
+ preserves pointer identity. Such patterns are common (Nil, [], Nothing,
+ ...) and warning about them would be pure noise.
+
+* Warnings about local functions (join points, local workers) name the
+ enclosing top-level binder too: locals often have meaningless names,
+ and any remedy is applied at the enclosing function anyway.
+ sc_top_fn tracks that binder, set when entering a top-level RHS (or a
+ specialised copy of one) and kept unchanged below that. The location
+ shown is the local's own definition site, so same-named locals can be
+ told apart; only when that is missing (e.g. for simplifier-made join
+ points) does the warning fall back to the parent's location.
+
+* The warning lists the top-level binders containing the specialised
+ calls ("called from"); each Call records the sc_top_fn of its call
+ site for this purpose. Self-calls of a top-level loop are dropped as
+ uninformative (in callToPat); a *local* loop's self-calls record its
+ parent, indistinguishable from the parent's entry call, so the parent
+ appears among the callers.
+
+* A function with no source span and no parent reached this module in an
+ interface unfolding: iface files record no spans for local binders, and
+ such loops typically float to top level in the consuming module. The
+ warning says "inlined from another module" instead of showing an
+ unhelpful span. Imported constructors are shown qualified — with the
+ function anonymous, they are what identifies the package to report the
+ reboxing to. For such a warning the call sites ("called from") are the
+ only located code to point at: following the inlining from one of them
+ identifies the reboxed loop.
+
Why BoxPassAlong does not warn: if the callee is specialised at that argument
position, its RULE rewrites the constructor-shaped call in the specialised
body and no box is ever rebuilt. That is exactly the good case that
@@ -1534,7 +1740,7 @@ scBind top_lvl env (NonRec bndr rhs) do_body
--
-- I tried always specialising non-recursive top-level bindings too,
-- but found some regressions (see !8135). So I backed off.
- = do { (rhs_usage, rhs', ws_rhs) <- scExpr env rhs
+ = do { (rhs_usage, rhs', ws_rhs) <- scExpr (setTopFn env bndr) rhs
-- At top level, we've already put all binders into scope; see initScEnv
-- Hence no need to call `extendBndr`. But we still want to
@@ -1554,7 +1760,8 @@ scBind top_lvl env (Rec prs) do_body
-- why it only applies at top level. But that's the way it has been
-- for a while. See #21456.
do { (body_usg, body', warnings_body) <- do_body rhs_env2
- ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (scExpr env) rhss
+ ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (\(b,r) -> scExpr (setTopFn env b) r)
+ (bndrs' `zip` rhss)
; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg)
`delCallsFor` bndrs'
bind' = Rec (bndrs' `zip` rhss')
@@ -1799,7 +2006,7 @@ markPassAlongArg _env _other usg = usg
mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
mkVarUsage env fn args
= case lookupHowBound env fn of
- Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)]
+ Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env) (sc_top_fn env)]
, scu_occs = emptyVarEnv }
Just RecArg -> SCU { scu_calls = emptyVarEnv
, scu_occs = unitVarEnv fn arg_occ }
@@ -1812,7 +2019,7 @@ mkVarUsage env fn args
scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (RhsInfo, SpecConstrWarnings)
scRecRhs env (bndr,rhs)
= do { let (arg_bndrs,body) = collectBinders rhs
- (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
+ (body_env, arg_bndrs') = extendBndrsWith RecArg (setTopFn env bndr) arg_bndrs
; (body_usg, body', body_ws) <- scExpr body_env body
; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
; return (RI { ri_rhs_usg = rhs_usg
@@ -1891,7 +2098,9 @@ specNonRec :: ScEnv
-- plus details of specialisations
specNonRec env body_calls rhs_info
- = specialise env body_calls rhs_info (initSpecInfo rhs_info)
+ = specialise env recur body_calls rhs_info (initSpecInfo rhs_info)
+ where
+ recur = ReboxNonRec (isJoinId (ri_fn rhs_info))
----------------------
specRec :: ScEnv
@@ -1911,6 +2120,13 @@ specRec env body_calls rhs_infos
where
opts = sc_opts env
+ -- A Rec group of one is genuinely self-recursive: the occurrence
+ -- analyser demotes non-recursive singletons to NonRec
+ recur ri = case rhs_infos of
+ [_] -> ReboxSelfRec
+ _ -> ReboxMutualRec [ idName (ri_fn ri') | ri' <- rhs_infos
+ , ri_fn ri' /= ri_fn ri ]
+
-- Loop, specialising, until you get no new specialisations
go, go_again :: Int -- Which iteration of the "until no new specialisations"
-- loop we are on; first iteration is 1
@@ -1925,7 +2141,8 @@ specRec env body_calls rhs_infos
-- , text "iteration" <+> int n_iter
-- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
-- ]) $
- do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
+ do { specs_w_usg <- zipWithM (\ri si -> specialise env (recur ri) seed_calls ri si)
+ rhs_infos spec_infos
; let (extra_usg_s, all_spec_infos, extra_ws ) = unzip3 specs_w_usg
extra_usg = combineUsages extra_usg_s
@@ -1963,6 +2180,7 @@ specRec env body_calls rhs_infos
----------------------
specialise
:: ScEnv
+ -> ReboxRecursivity -- How the function recurses, for warnings
-> CallEnv -- Info on newly-discovered calls to this function
-> RhsInfo
-> SpecInfo -- Original RHS plus patterns dealt with
@@ -1977,8 +2195,8 @@ specialise
-- So when we make a specialised copy of the RHS, we're starting
-- from an RHS whose nested functions have been optimised already.
-specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
- , ri_lam_body = body, ri_arg_occs = arg_occs })
+specialise env recur bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
+ , ri_lam_body = body, ri_arg_occs = arg_occs })
spec_info@(SI { si_specs = specs, si_n_specs = spec_count
, si_mb_unspec = mb_unspec })
| isDeadEndId fn -- Note [Do not specialise diverging functions]
@@ -2001,7 +2219,9 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
; let n_pats = length new_pats
-- Warn about committed specialisations that will rebox;
-- see Note [Reboxing warning]
- rebox_ws = [ SpecReboxed (idName fn) (cp_rebox p)
+ rebox_ws = [ SpecReboxed (idName fn) (idType fn) (sc_top_fn env)
+ recur [ReboxedPat (patShapes p) (cp_rebox p)]
+ (cp_callers p)
| p <- new_pats, not (null (cp_rebox p)) ]
-- ; when (not (null new_pats) || isJust mb_unspec) $
-- pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"
@@ -2013,7 +2233,9 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
-- , text "arg_occs" <+> ppr arg_occs
-- , text "new_pats" <+> ppr new_pats])
- ; let spec_env = decreaseSpecCount env n_pats
+ ; let spec_env = setTopFn (decreaseSpecCount env n_pats) fn
+ -- setTopFn: attribute warnings from re-analysing the
+ -- specialised copies of a top-level fn's body to fn
; (spec_usgs, new_specs, new_wss) <- mapAndUnzip3M (spec_one spec_env fn arg_bndrs body)
(new_pats `zip` [spec_count..])
-- See Note [Specialise original body]
@@ -2565,30 +2787,127 @@ data CallPat = CP { cp_qvars :: [Var] -- Quantified variables
, cp_args :: [CoreExpr] -- Arguments
, cp_strict_args :: [Var] -- Arguments we want to pass unlifted even if they are boxed
-- See Note [SpecConstr and strict fields]
- , cp_rebox :: [Name] } -- Constructors matched by this pattern whose box
+ , cp_rebox :: [Name] -- Constructors matched by this pattern whose box
-- is also used; see Note [Reboxing warning]
+ , cp_callers :: [Name] } -- Enclosing top-level binders of the calls this
+ -- pattern came from; see Note [Reboxing warning]
-- See Note [SpecConstr call patterns]
instance Outputable CallPat where
- ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args = strict, cp_rebox = rebox })
+ ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args = strict, cp_rebox = rebox
+ , cp_callers = callers })
= text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma
, text "cp_args =" <+> ppr args
, text "cp_strict_args = " <> ppr strict
- , text "cp_rebox = " <> ppr rebox ])
+ , text "cp_rebox = " <> ppr rebox
+ , text "cp_callers = " <> ppr callers ])
+
+-- | One call pattern as displayed by the reboxing warning: the shapes of
+-- the pattern's arguments, and the reboxed constructors among them.
+-- See Note [Reboxing warning]
+data ReboxedPat = ReboxedPat [PatShape] [Name]
+
+-- | The constructor skeleton of one call-pattern argument, as displayed
+-- by the reboxing warning
+data PatShape = ShapeWild
+ | ShapeLit Literal
+ | ShapeCon DataCon [PatShape]
+
+-- | The displayed shapes of a pattern's value arguments
+patShapes :: CallPat -> [PatShape]
+patShapes (CP { cp_args = args }) = mapMaybe arg_shape args
+ where
+ arg_shape (Type {}) = Nothing
+ arg_shape (Coercion {}) = Nothing
+ arg_shape (Cast e _) = arg_shape e
+ arg_shape (Tick _ e) = arg_shape e
+ arg_shape (Lit l) = Just (ShapeLit l)
+ arg_shape e
+ | (Var f, f_args) <- collectArgs e
+ , Just dc <- isDataConWorkId_maybe f
+ = Just (ShapeCon dc (mapMaybe arg_shape f_args))
+ | otherwise
+ = Just ShapeWild
+
+-- | Stable comparison, used both to merge identically-rendering warnings
+-- and to order a warning's patterns deterministically
+cmpReboxedPat :: ReboxedPat -> ReboxedPat -> Ordering
+cmpReboxedPat (ReboxedPat ss1 cs1) (ReboxedPat ss2 cs2)
+ = cmpListBy cmpShape ss1 ss2
+ `mappend` cmpListBy stableNameCmp (sortBy stableNameCmp cs1)
+ (sortBy stableNameCmp cs2)
+
+cmpShape :: PatShape -> PatShape -> Ordering
+cmpShape ShapeWild ShapeWild = EQ
+cmpShape ShapeWild _ = LT
+cmpShape _ ShapeWild = GT
+cmpShape (ShapeLit l1) (ShapeLit l2) = compare l1 l2
+cmpShape (ShapeLit _) _ = LT
+cmpShape _ (ShapeLit _) = GT
+cmpShape (ShapeCon c1 a1) (ShapeCon c2 a2)
+ = stableNameCmp (dataConName c1) (dataConName c2)
+ `mappend` cmpListBy cmpShape a1 a2
+
+cmpListBy :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
+cmpListBy _ [] [] = EQ
+cmpListBy _ [] _ = LT
+cmpListBy _ _ [] = GT
+cmpListBy cmp (x1:xs1) (x2:xs2) = cmp x1 x2 `mappend` cmpListBy cmp xs1 xs2
+
+-- Constructors are shown by bare occurrence name: shapes illustrate,
+-- while the warning's "reboxes" list identifies (with qualification)
+pprPatShape :: PatShape -> SDoc
+pprPatShape = go (10 :: Int) -- Depth cap against pathological patterns
+ where
+ go _ ShapeWild = underscore
+ go _ (ShapeLit l) = ppr l
+ go _ (ShapeCon dc []) = ppr (getOccName dc)
+ go 0 (ShapeCon {}) = text "..."
+ go d (ShapeCon dc args)
+ | isTupleDataCon dc
+ = parens (pprWithCommas (go d') args)
+ | isUnboxedTupleDataCon dc
+ = text "(#" <+> pprWithCommas (go d') args <+> text "#)"
+ | dataConIsInfix dc, [a1, a2] <- args
+ = parens (go d' a1 <+> pprInfixOcc (getOccName dc) <+> go d' a2)
+ | otherwise
+ = parens (pprPrefixOcc (getOccName dc) <+> sep (map (go d') args))
+ where d' = d - 1
+
+-- | How the function that SpecConstr specialised recurses, as bound in
+-- the post-optimisation program. See Note [Reboxing warning]
+data ReboxRecursivity
+ = ReboxSelfRec
+ | ReboxMutualRec [Name] -- The sibling binders of its Rec group
+ | ReboxNonRec Bool -- True <=> a join point
data SpecConstrWarning
= SpecFailForcedArgCount { spec_failed_fun_name :: Name }
| SpecReboxed { spec_rebox_fun_name :: Name -- The specialised function
- , spec_rebox_cons :: [Name] } -- The reboxed constructor(s)
+ , spec_rebox_fun_ty :: Type -- Its type: often the only clue
+ -- to a span-less function's identity
+ , spec_rebox_parent :: Maybe Name -- Its enclosing top-level
+ -- binder, if fn is local
+ , spec_rebox_recur :: ReboxRecursivity
+ , spec_rebox_pats :: [ReboxedPat] -- The patterns that rebox
+ , spec_rebox_callers :: [Name] } -- Top-level binders containing
+ -- the specialised calls
-- See Note [Reboxing warning]
- deriving Eq
type SpecConstrWarnings = [SpecConstrWarning]
instance Outputable SpecConstrWarning where
ppr (SpecFailForcedArgCount name) = ppr name <+> pprDefinedAt name
- ppr (SpecReboxed fn dcs) = ppr fn <+> parens (pprWithCommas ppr dcs) <+> pprDefinedAt fn
+ ppr (SpecReboxed fn _ty mb_parent _recur pats _callers)
+ = ppr fn <+> parens (pprWithCommas ppr dcs) <+> pp_defn
+ where
+ dcs = [ dc | ReboxedPat _ cons <- pats, dc <- cons ]
+ -- A local fn often has no useful location; point at its
+ -- enclosing top-level binder instead
+ pp_defn = case mb_parent of
+ Just parent -> text "in" <+> ppr parent <> comma <+> pprDefinedAt parent
+ Nothing -> pprDefinedAt fn
combineSpecWarning :: SpecConstrWarnings -> SpecConstrWarnings -> SpecConstrWarnings
combineSpecWarning = (++)
@@ -2735,7 +3054,7 @@ callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
-- Type variables come first, since they may scope
-- over the following term variables
-- The [CoreExpr] are the argument patterns for the rule
-callToPat env bndr_occs call@(Call fn args con_env)
+callToPat env bndr_occs call@(Call fn args con_env mb_caller)
= do { let in_scope = substInScopeSet (sc_subst env)
; arg_quads <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)
@@ -2784,7 +3103,11 @@ callToPat env bndr_occs call@(Call fn args con_env)
if interesting && null bad_covars
then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats
, cp_strict_args = concat cbv_ids
- , cp_rebox = concat rebox_cons }
+ , cp_rebox = concat rebox_cons
+ -- Self-recursive calls are no clue
+ -- to the function's identity
+ , cp_callers = [ c | Just c <- [mb_caller]
+ , c /= idName fn ] }
-- ; pprTraceM "callToPatOut" $
-- vcat [ text "fn:" <+> ppr fn
-- , text "args:" <+> ppr args
@@ -2888,8 +3211,10 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str
; let args' = [ p | (_, p, _, _) <- prs ] :: [CoreArg]
cbvs = concat [ cbv | (_, _, cbv, _) <- prs ]
rebox_nested = concat [ rbs | (_, _, _, rbs) <- prs ]
- -- rebox_here: see Note [Reboxing warning]
- rebox_here = [ dataConName dc | box_use == BoxOther ]
+ -- rebox_here: see Note [Reboxing warning]; nullary
+ -- constructors rebox for free, so don't warn about them
+ rebox_here = [ dataConName dc
+ | box_use == BoxOther, dataConRepArity dc > 0 ]
; assertPpr (length con_str == length (filter isRuntimeArg rest_args))
( ppr con_str $$ ppr rest_args $$
ppr (length con_str) $$ ppr (length rest_args)
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -534,6 +534,35 @@ of ``-W(no-)*``.
the call-pattern analysis by wrapping the argument in ``GHC.Exts.lazy``
at the call site, or :ghc-flag:`-fno-spec-constr`.
+ The warning shows the specialised function's type, which is often the
+ clearest clue to its identity when its name carries no meaning,
+ followed by a block of labelled facts: ``source:`` — the function's
+ definition site (for a local function, also the enclosing top-level
+ binding); ``recursivity:`` — whether the function is self-recursive,
+ mutually recursive (naming the other functions of its recursive
+ group), or non-recursive (for example a join point), as bound in the
+ optimised program, whose shape can differ from the source's;
+ ``called from:`` — the top-level bindings containing the specialised
+ calls; ``call patterns:`` — the calls the function was specialised
+ for, shown as the constructor skeletons of their arguments, each
+ alongside the constructors that the specialisation reboxes (for
+ example ``go (_ : _) (Bin _ _ _) -- reboxes ‘Bin’``). One warning is emitted per
+ specialised function, and warnings that would read identically are
+ merged into one. Specialisations on nullary constructors are not
+ reported, since "reboxing" a nullary constructor simply references
+ its shared static closure.
+
+ A ``source:`` reading ``inlined from another module (no source
+ location)`` concerns a function that reached the module being compiled
+ through another module's unfolding; interface files record no source
+ locations for local functions. Such reboxing cannot be addressed in
+ the module being compiled — consider reporting it against the package
+ defining the inlined code. Constructors imported from other modules
+ are shown qualified with their defining module as a hint to where that
+ is. For such a warning the ``called from:`` sites are the only located
+ code — following the inlining from one of them identifies the reboxed
+ code.
+
The analysis behind this warning is approximate: it can both miss genuine
reboxing and report reboxing that later optimisations eliminate or that
only occurs on cold code paths.
=====================================
testsuite/tests/simplCore/should_compile/T27628.stderr
=====================================
@@ -1,9 +1,14 @@
T27628.hs: warning: [-Wspec-constr-reboxing]
- SpecConstr specialised the following function(s) on a constructor argument that is also used boxed:
- $wgo (LC) Defined at T27628.hs:17:1
- The specialised code allocates a fresh constructor at each such use ("reboxing"),
- which can increase allocation and defeat pointer-equality-based sharing.
- Possible remedies: exclude the type with an {-# ANN type T NoSpecConstr #-} pragma,
- hide the constructor from SpecConstr by wrapping the call-site argument in GHC.Exts.lazy,
- or use -fno-spec-constr.
+ SpecConstr specialised
+ ‘$wgo :: LC
+ -> GHC.Internal.Prim.Int#
+ -> GHC.Internal.Prim.Int#
+ -> GHC.Internal.Prim.Int#’
+ source: T27628.hs:17:1
+ recursivity: self-recursive
+ called from: ‘f’
+ call pattern: $wgo (LC _ _) -- reboxes ‘LC’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
=====================================
testsuite/tests/simplCore/should_compile/T27628b.stderr
=====================================
@@ -1,9 +1,10 @@
T27628b.hs: warning: [-Wspec-constr-reboxing]
- SpecConstr specialised the following function(s) on a constructor argument that is also used boxed:
- merge (Bin) Defined at T27628b.hs:10:1
- The specialised code allocates a fresh constructor at each such use ("reboxing"),
- which can increase allocation and defeat pointer-equality-based sharing.
- Possible remedies: exclude the type with an {-# ANN type T NoSpecConstr #-} pragma,
- hide the constructor from SpecConstr by wrapping the call-site argument in GHC.Exts.lazy,
- or use -fno-spec-constr.
+ SpecConstr specialised ‘merge :: T -> T -> T’
+ source: T27628b.hs:10:1
+ recursivity: self-recursive
+ called from: ‘f’
+ call pattern: merge (Bin _ _ _) -- reboxes ‘Bin’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
=====================================
testsuite/tests/simplCore/should_compile/T27628e.hs
=====================================
@@ -0,0 +1,17 @@
+-- Like T27628b, but the specialisation pattern is the *nullary*
+-- constructor Tip (the call passes Tip; the box is also returned).
+-- Reboxing a nullary constructor is free (it is a shared static
+-- closure), so no warning should be emitted.
+module T27628e where
+
+data T = Tip | Bin Int T T
+
+merge :: T -> T -> T
+merge Tip t2 = t2
+merge t1@(Bin k l r) t2 =
+ case t2 of
+ Tip -> t1
+ Bin _ l2 r2 -> Bin k (merge l l2) (merge r r2)
+
+g :: T -> T
+g t = merge t Tip
=====================================
testsuite/tests/simplCore/should_compile/T27628f.hs
=====================================
@@ -0,0 +1,16 @@
+-- Like T27628b, but the specialised function is a *local* worker.
+-- The warning should attribute it to the enclosing top-level binder f.
+-- (merge captures n so that it is not floated to the top level.)
+module T27628f where
+
+data T = Tip | Bin Int T T
+
+f :: Int -> T -> T
+f n t0 = merge (Bin n Tip Tip) t0
+ where
+ merge :: T -> T -> T
+ merge Tip _ = Tip
+ merge t1@(Bin k l r) t2 =
+ case t2 of
+ Tip -> t1
+ Bin _ l2 r2 -> Bin (k + n) (merge l l2) (merge r r2)
=====================================
testsuite/tests/simplCore/should_compile/T27628f.stderr
=====================================
@@ -0,0 +1,10 @@
+T27628f.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘merge :: T -> T -> T’
+ source: ‘f’ at T27628f.hs:12:5
+ recursivity: self-recursive
+ called from: ‘f’
+ call pattern: merge (Bin _ _ _) -- reboxes ‘Bin’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
=====================================
testsuite/tests/simplCore/should_compile/T27628g.hs
=====================================
@@ -0,0 +1,15 @@
+module T27628g where
+
+data T a = Tip | Bin a (T a) (T a)
+
+-- merge has no free value variables, so the float-out pass lifts it to
+-- top level as poly_merge, abstracted over 'a'. The reboxing warning
+-- should still point at merge's definition site.
+f :: a -> T a -> T a
+f x t = merge (Bin x Tip Tip) t
+ where
+ merge Tip t2 = t2
+ merge t1@(Bin k l r) t2 =
+ case t2 of
+ Tip -> t1
+ Bin _ l2 r2 -> Bin k (merge l l2) (merge r r2)
=====================================
testsuite/tests/simplCore/should_compile/T27628g.stderr
=====================================
@@ -0,0 +1,10 @@
+T27628g.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘poly_merge :: T a -> T a -> T a’
+ source: T27628g.hs:11:5
+ recursivity: self-recursive
+ called from: ‘f’
+ call pattern: poly_merge (Bin _ _ _) -- reboxes ‘Bin’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
=====================================
testsuite/tests/simplCore/should_compile/T27628h.hs
=====================================
@@ -0,0 +1,8 @@
+-- Specialising the span-less copy of T27628h_M.merge must warn with the
+-- "inlined from another module" wording and a module-qualified constructor.
+module T27628h where
+
+import T27628h_M
+
+g :: Int -> T Int -> T Int
+g x t = f x (f x t)
=====================================
testsuite/tests/simplCore/should_compile/T27628h.stderr
=====================================
@@ -0,0 +1,20 @@
+./T27628h_M.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘poly_merge :: T a -> T a -> T a’
+ source: T27628h_M.hs:11:5
+ recursivity: self-recursive
+ called from: ‘f’
+ call pattern: poly_merge (Bin _ _ _) -- reboxes ‘Bin’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+T27628h.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘merge :: T Int -> T Int -> T Int’
+ source: inlined from another module (no source location)
+ recursivity: self-recursive
+ called from: ‘g’
+ call pattern: merge (Bin _ _ _) -- reboxes ‘T27628h_M.Bin’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
=====================================
testsuite/tests/simplCore/should_compile/T27628h_M.hs
=====================================
@@ -0,0 +1,16 @@
+-- The INLINE unfolding of f carries the local loop 'merge' into importing
+-- modules, where it is specialised without a source span: iface unfoldings
+-- record no spans for local binders.
+module T27628h_M where
+
+data T a = Tip | Bin a (T a) (T a)
+
+f :: a -> T a -> T a
+f x t = merge (Bin x Tip Tip) t
+ where
+ merge Tip t2 = t2
+ merge t1@(Bin k l r) t2 =
+ case t2 of
+ Tip -> t1
+ Bin _ l2 r2 -> Bin k (merge l l2) (merge r r2)
+{-# INLINE f #-}
=====================================
testsuite/tests/simplCore/should_compile/T27628i.hs
=====================================
@@ -0,0 +1,15 @@
+-- The span-less copies of f1's and f3's 'merge' render identically, so
+-- one warning covers both; f2's 'merge' differs in type and gets its
+-- own warning.
+module T27628i where
+
+import T27628i_M
+
+g1 :: Int -> T Int -> T Int
+g1 x t = f1 x (f1 x t)
+
+g2 :: Int -> S Int -> S Int
+g2 x t = f2 x (f2 x t)
+
+g3 :: Int -> T Int -> T Int
+g3 x t = f3 x (f3 x t)
=====================================
testsuite/tests/simplCore/should_compile/T27628i.stderr
=====================================
@@ -0,0 +1,51 @@
+./T27628i_M.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘poly_merge :: T a -> T a -> T a’
+ source: T27628i_M.hs:36:5
+ recursivity: self-recursive
+ called from: ‘f3’
+ call pattern: poly_merge (Bin _ _ _) -- reboxes ‘Bin’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+./T27628i_M.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘poly_merge :: S a -> S a -> S a’
+ source: T27628i_M.hs:24:5
+ recursivity: self-recursive
+ called from: ‘f2’
+ call pattern: poly_merge (Node _ _ _) -- reboxes ‘Node’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+./T27628i_M.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘poly_merge :: T a -> T a -> T a’
+ source: T27628i_M.hs:14:5
+ recursivity: self-recursive
+ called from: ‘f1’
+ call pattern: poly_merge (Bin _ _ _) -- reboxes ‘Bin’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+T27628i.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘merge :: T Int -> T Int -> T Int’
+ source: inlined from another module (no source location)
+ recursivity: self-recursive
+ called from: ‘g1’, ‘g3’
+ call pattern: merge (Bin _ _ _) -- reboxes ‘T27628i_M.Bin’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+T27628i.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘merge :: S Int -> S Int -> S Int’
+ source: inlined from another module (no source location)
+ recursivity: self-recursive
+ called from: ‘g2’
+ call pattern: merge (Node _ _ _)
+ -- reboxes ‘T27628i_M.Node’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
=====================================
testsuite/tests/simplCore/should_compile/T27628i_M.hs
=====================================
@@ -0,0 +1,41 @@
+-- Three INLINE functions with local loops named 'merge': f1 and f3 over
+-- T, f2 over S. In an importing module all three loops arrive span-less
+-- (iface unfoldings record no spans for local binders). f1's and f3's
+-- copies render identically (same name and type) and must merge into
+-- one warning; f2's differs in type and must stay separate.
+module T27628i_M where
+
+data T a = Tip | Bin a (T a) (T a)
+data S a = Leaf | Node a (S a) (S a)
+
+f1 :: a -> T a -> T a
+f1 x t = merge (Bin x Tip Tip) t
+ where
+ merge Tip t2 = t2
+ merge t1@(Bin k l r) t2 =
+ case t2 of
+ Tip -> t1
+ Bin _ l2 r2 -> Bin k (merge l l2) (merge r r2)
+{-# INLINE f1 #-}
+
+f2 :: a -> S a -> S a
+f2 x t = merge (Node x Leaf Leaf) t
+ where
+ merge Leaf t2 = t2
+ merge t1@(Node k l r) t2 =
+ case t2 of
+ Leaf -> t1
+ Node _ l2 r2 -> Node k (merge l l2) (merge r r2)
+{-# INLINE f2 #-}
+
+-- Like f1 but recursing with the children swapped, so the two loops
+-- stay distinct functions while their warnings render the same
+f3 :: a -> T a -> T a
+f3 x t = merge (Bin x Tip Tip) t
+ where
+ merge Tip t2 = t2
+ merge t1@(Bin k l r) t2 =
+ case t2 of
+ Tip -> t1
+ Bin _ l2 r2 -> Bin k (merge r r2) (merge l l2)
+{-# INLINE f3 #-}
=====================================
testsuite/tests/simplCore/should_compile/T27628j.hs
=====================================
@@ -0,0 +1,24 @@
+-- A mutually recursive pair in the style of T27628b. g calls both
+-- functions with a constructor argument: the non-loop-breaker inlines
+-- into g, but the loop breaker's call survives to SpecConstr, whose
+-- warning classifies it as mutually recursive and names the sibling.
+module T27628j where
+
+data T = Tip | Bin Int T T
+
+mergeA :: T -> T -> T
+mergeA Tip t2 = t2
+mergeA t1@(Bin k l r) t2 =
+ case t2 of
+ Tip -> t1
+ Bin _ l2 r2 -> Bin k (mergeB l l2) (mergeB r r2)
+
+mergeB :: T -> T -> T
+mergeB Tip t2 = t2
+mergeB t1@(Bin k l r) t2 =
+ case t2 of
+ Tip -> t1
+ Bin _ l2 r2 -> Bin k (mergeA r r2) (mergeA l l2)
+
+g :: Int -> T -> T
+g x t = mergeA (Bin x Tip Tip) (mergeB (Bin x Tip Tip) t)
=====================================
testsuite/tests/simplCore/should_compile/T27628j.stderr
=====================================
@@ -0,0 +1,10 @@
+T27628j.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘mergeB :: T -> T -> T’
+ source: T27628j.hs:17:1
+ recursivity: mutually recursive with ‘mergeA’
+ called from: ‘g’
+ call pattern: mergeB (Bin _ _ _) -- reboxes ‘Bin’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
=====================================
testsuite/tests/simplCore/should_compile/T27628k.hs
=====================================
@@ -0,0 +1,20 @@
+-- 'go' is specialised for two different call patterns, A and B, and
+-- both rebox (t is scrutinised but also passed whole to 'sink').
+-- Expect one warning for 'go' listing both call patterns.
+module T27628k where
+
+data T = A Int | B Int | C
+
+-- The guard makes the use of 't' lazy, so boxity analysis keeps the
+-- box: $wsink wants it.
+sink :: T -> Int -> Int
+sink t k
+ | k < 0 = k
+ | otherwise = case t of A n -> n; B n -> n; C -> 0
+{-# NOINLINE sink #-}
+
+go :: T -> Int -> Int
+go t k = case t of
+ A n -> if k == 0 then sink t k else go (B n) (k - 1)
+ B n -> if k == 0 then sink t k else go (A n) (k - 1)
+ C -> 0
=====================================
testsuite/tests/simplCore/should_compile/T27628k.stderr
=====================================
@@ -0,0 +1,11 @@
+T27628k.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘go :: T -> Int -> Int’
+ source: T27628k.hs:17:1
+ recursivity: self-recursive
+ call patterns: go (A _) (I# _) -- reboxes ‘A’
+ go (B _) (I# _) -- reboxes ‘B’
+ These constructor arguments are also used boxed, so the
+ specialisations may increase allocation and defeat
+ pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
=====================================
testsuite/tests/simplCore/should_compile/T27628l.hs
=====================================
@@ -0,0 +1,38 @@
+-- Max and Min (mimicking GHC.Internal.Data.Functor.Utils) both inline
+-- base's foldl' and stimes templates, so each instance's methods bind
+-- local loops with the SAME uniques as the other's. The warnings must
+-- stay separate per instance (keyed on (parent, function)), not be
+-- fused into one with doubled callers; see Note [Reboxing warning].
+module T27628l where
+
+import Data.List (foldl')
+
+newtype Max a = Max (Maybe a)
+
+instance Ord a => Semigroup (Max a) where
+ {-# INLINE (<>) #-}
+ m <> Max Nothing = m
+ Max Nothing <> n = n
+ (Max m@(Just x)) <> (Max n@(Just y))
+ | x >= y = Max m
+ | otherwise = Max n
+
+instance Ord a => Monoid (Max a) where
+ mempty = Max Nothing
+ mconcat = foldl' (<>) mempty
+ {-# INLINE mconcat #-}
+
+newtype Min a = Min (Maybe a)
+
+instance Ord a => Semigroup (Min a) where
+ {-# INLINE (<>) #-}
+ m <> Min Nothing = m
+ Min Nothing <> n = n
+ (Min m@(Just x)) <> (Min n@(Just y))
+ | x <= y = Min m
+ | otherwise = Min n
+
+instance Ord a => Monoid (Min a) where
+ mempty = Min Nothing
+ mconcat = foldl' (<>) mempty
+ {-# INLINE mconcat #-}
=====================================
testsuite/tests/simplCore/should_compile/T27628l.stderr
=====================================
@@ -0,0 +1,66 @@
+T27628l.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘go1 :: [Max a] -> Max a -> Max a’
+ source: ‘$cmconcat’ at T27628l.hs:22:5
+ recursivity: self-recursive
+ called from: ‘$cmconcat’
+ call pattern: go1 _ (Just _)
+ -- reboxes ‘GHC.Internal.Maybe.Just’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+T27628l.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘exit :: Max a -> b -> Max a’
+ source: ‘$cstimes’ at T27628l.hs:12:10
+ recursivity: non-recursive (a join point)
+ called from: ‘$cstimes’
+ call pattern: exit (Just _) _
+ -- reboxes ‘GHC.Internal.Maybe.Just’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+T27628l.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘g :: Max a -> b -> Max a -> Max a’
+ source: ‘$cstimes’ at T27628l.hs:12:10
+ recursivity: self-recursive
+ called from: ‘$cstimes’
+ call pattern: g (Just _) _ _
+ -- reboxes ‘GHC.Internal.Maybe.Just’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+T27628l.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘go1 :: [Min a] -> Min a -> Min a’
+ source: ‘$cmconcat’ at T27628l.hs:37:5
+ recursivity: self-recursive
+ called from: ‘$cmconcat’
+ call pattern: go1 _ (Just _)
+ -- reboxes ‘GHC.Internal.Maybe.Just’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+T27628l.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘exit :: Min a -> b -> Min a’
+ source: ‘$cstimes’ at T27628l.hs:27:10
+ recursivity: non-recursive (a join point)
+ called from: ‘$cstimes’
+ call pattern: exit (Just _) _
+ -- reboxes ‘GHC.Internal.Maybe.Just’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
+T27628l.hs: warning: [-Wspec-constr-reboxing]
+ SpecConstr specialised ‘g :: Min a -> b -> Min a -> Min a’
+ source: ‘$cstimes’ at T27628l.hs:27:10
+ recursivity: self-recursive
+ called from: ‘$cstimes’
+ call pattern: g (Just _) _ _
+ -- reboxes ‘GHC.Internal.Maybe.Just’
+ This constructor argument is also used boxed, so the specialisation
+ may increase allocation and defeat pointer-equality-based sharing.
+ See -Wspec-constr-reboxing in the users guide for possible remedies.
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -617,3 +617,11 @@ test('T27628', normal, compile, ['-O2 -Wspec-constr-reboxing'])
test('T27628b', normal, compile, ['-O2 -Wspec-constr-reboxing'])
test('T27628c', normal, compile, ['-O2 -Wspec-constr-reboxing'])
test('T27628d', normal, compile, ['-O2 -Wspec-constr-reboxing'])
+test('T27628e', normal, compile, ['-O2 -Wspec-constr-reboxing'])
+test('T27628f', normal, compile, ['-O2 -Wspec-constr-reboxing'])
+test('T27628g', normal, compile, ['-O2 -Wspec-constr-reboxing -dsuppress-uniques'])
+test('T27628h', [extra_files(['T27628h_M.hs'])], multimod_compile, ['T27628h', '-v0 -O2 -Wspec-constr-reboxing -dsuppress-uniques'])
+test('T27628i', [extra_files(['T27628i_M.hs'])], multimod_compile, ['T27628i', '-v0 -O2 -Wspec-constr-reboxing -dsuppress-uniques'])
+test('T27628j', normal, compile, ['-O2 -Wspec-constr-reboxing'])
+test('T27628k', normal, compile, ['-O2 -Wspec-constr-reboxing'])
+test('T27628l', normal, compile, ['-O2 -Wspec-constr-reboxing -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e9f8bc7f5d8acf390e0145030dbbe…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e9f8bc7f5d8acf390e0145030dbbe…
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] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26
by Marge Bot (＠marge-bot) 24 Aug '26
24 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
84b9fd2f by Andreas Klebinger at 2026-08-24T02:45:47-04:00
rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
We accidentally operated over `uint64_t*` when we should use `uint8_t`.
Fixes #27569
- - - - -
7e4eb741 by Alan Zimmerman at 2026-08-24T02:45:47-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
- - - - -
6 changed files:
- rts/linker/elf_reloc_riscv64.c
- 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:
=====================================
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,
=====================================
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/c816680d958ebed747a4ef9e7353e5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c816680d958ebed747a4ef9e7353e5…
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] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26
by Marge Bot (＠marge-bot) 24 Aug '26
24 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
eb28622d by Andreas Klebinger at 2026-08-24T00:38:04-04:00
rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
We accidentally operated over `uint64_t*` when we should use `uint8_t`.
Fixes #27569
- - - - -
c816680d by Alan Zimmerman at 2026-08-24T00:38: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
- - - - -
6 changed files:
- rts/linker/elf_reloc_riscv64.c
- 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:
=====================================
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,
=====================================
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/5af7613fd719b1541ee93ac41f5a71…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5af7613fd719b1541ee93ac41f5a71…
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] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26
by Marge Bot (＠marge-bot) 24 Aug '26
24 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
79765ad4 by Andreas Klebinger at 2026-08-23T20:29: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
- - - - -
5af7613f by Alan Zimmerman at 2026-08-23T20:29:30-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
- - - - -
6 changed files:
- rts/linker/elf_reloc_riscv64.c
- 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:
=====================================
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,
=====================================
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/e54da4bb5ca046002f3cd727baa93c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e54da4bb5ca046002f3cd727baa93c…
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/T27727] haddock: Fix overeager defaulting
by Krzysztof Gogolewski (＠monoidal) 23 Aug '26
by Krzysztof Gogolewski (＠monoidal) 23 Aug '26
23 Aug '26
Krzysztof Gogolewski pushed to branch wip/T27727 at Glasgow Haskell Compiler / GHC
Commits:
bcb7d61a by Krzysztof Gogolewski at 2026-08-24T00:23:53+02:00
haddock: Fix overeager defaulting
When defaulting RuntimeReps, we don't want to display
forall (f :: forall r. TYPE r -> Type) . f Int# -> f Int#
as
forall (f :: Type -> Type) . f Int# -> f Int#
because that's ill-kinded. This was already fixed in GHC in #16468,
but Haddock has its own defaulting which needs a similar change.
Fixes #27727.
- - - - -
5 changed files:
- compiler/GHC/Iface/Type.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/html-test/Main.hs
- + utils/haddock/html-test/ref/T27727.html
- + utils/haddock/html-test/src/T27727.hs
Changes:
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1258,6 +1258,8 @@ Wrinkles:
The toplevel function type is matched as IfaceFunTy, where we recurse into
'go' by passing False for 'rank1'.
The forall in the first argument then skips adding a substitution for 'r2'.
+ The same wrinkle applies to Haddock, which has its own copy of defaulting
+ in 'defaultRuntimeRepVars'.
(W2) 'defaultIfaceTyVarsOfKind' ought to be called only once when printing a
type.
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -843,37 +843,40 @@ orderedFVs ignore_tvs tys
-------------------------------------------------------------------------------
--- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to
--- 'LiftedType'. See 'defaultRuntimeRepVars' in GHC.Iface.Type the original such
+-- | Traverses the type, defaulting top-level type variables of kind 'RuntimeRep' to
+-- 'LiftedType'. See 'defaultIfaceTyVarsOfKind' in GHC.Iface.Type the original such
-- function working over `IfaceType`'s.
defaultRuntimeRepVars :: Type -> Type
-defaultRuntimeRepVars = go emptyVarEnv
+defaultRuntimeRepVars = go True emptyVarEnv
where
- go :: TyVarEnv () -> Type -> Type
- go subs (ForAllTy (Bndr var flg) ty)
- | isRuntimeRepVar var
+ go :: Bool -> TyVarEnv () -> Type -> Type
+ -- See Wrinkle (W1) in Note [Defaulting RuntimeRep variables] in GHC.Iface.Type
+ -- for why we have the 'rank1' parameter.
+ go rank1 subs (ForAllTy (Bndr var flg) ty)
+ | rank1
+ , isRuntimeRepVar var
, isInvisibleForAllTyFlag flg =
let subs' = extendVarEnv subs var ()
- in go subs' ty
+ in go rank1 subs' ty
| otherwise =
ForAllTy
- (Bndr (updateTyVarKind (go subs) var) flg)
- (go subs ty)
- go subs (TyVarTy tv)
+ (Bndr (updateTyVarKind (go False subs) var) flg)
+ (go rank1 subs ty)
+ go _ subs (TyVarTy tv)
| tv `elemVarEnv` subs =
liftedRepTy
| otherwise =
- TyVarTy (updateTyVarKind (go subs) tv)
- go subs (TyConApp tc tc_args) =
- TyConApp tc (map (go subs) tc_args)
- go subs (FunTy af w arg res) =
- FunTy af (go subs w) (go subs arg) (go subs res)
- go subs (AppTy t u) =
- AppTy (go subs t) (go subs u)
- go subs (CastTy x co) =
- CastTy (go subs x) co
- go _ ty@(LitTy{}) = ty
- go _ ty@(CoercionTy{}) = ty
+ TyVarTy (updateTyVarKind (go False subs) tv)
+ go _ subs (TyConApp tc tc_args) =
+ TyConApp tc (map (go False subs) tc_args)
+ go rank1 subs (FunTy af w arg res) =
+ FunTy af (go False subs w) (go False subs arg) (go rank1 subs res)
+ go _ subs (AppTy t u) =
+ AppTy (go False subs t) (go False subs u)
+ go rank1 subs (CastTy x co) =
+ CastTy (go rank1 subs x) co
+ go _ _ ty@(LitTy{}) = ty
+ go _ _ ty@(CoercionTy{}) = ty
fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI
fromMaybeContext Nothing = HsContext noExtField []
=====================================
utils/haddock/html-test/Main.hs
=====================================
@@ -53,8 +53,8 @@ stripIfRequired mdl =
preserveLinksModules :: [String]
preserveLinksModules = ["Bug253.html", "NamespacedIdentifiers.html"]
-ingoredTests :: [String]
-ingoredTests =
+ignoredTests :: [String]
+ignoredTests =
[
-- Currently some declarations are exported twice
-- we need a reliable way to deduplicate here.
@@ -76,6 +76,6 @@ ignoredOneShotTests =
]
checkIgnore :: FilePath -> Bool
-checkIgnore file | takeBaseName file `elem` ingoredTests = True
+checkIgnore file | takeBaseName file `elem` ignoredTests = True
checkIgnore file@(c:_) | takeExtension file == ".html" && isUpper c = False
checkIgnore _ = True
=====================================
utils/haddock/html-test/ref/T27727.html
=====================================
@@ -0,0 +1,84 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><meta name="viewport" content="width=device-width, initial-scale=1"
+ /><title
+ >T27727</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script type="text/x-mathjax-config"
+ >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-…" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><span class="caption empty"
+ > </span
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >Index</a
+ ></li
+ ></ul
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >None</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >T27727</p
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:demonstration" class="def"
+ >demonstration</a
+ > :: <span class="keyword"
+ >forall</span
+ > (f :: <span class="keyword"
+ >forall</span
+ > r. <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > r -> <a href="#" title="Data.Kind"
+ >Type</a
+ >). f <a href="#" title="GHC.Exts"
+ >Int#</a
+ > -> f <a href="#" title="GHC.Exts"
+ >Int#</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:f" class="def"
+ >f</a
+ > :: (<span class="keyword"
+ >forall</span
+ > r. P r) -> P <a href="#" title="GHC.Exts"
+ >LiftedRep</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></div
+ ></div
+ ></body
+ ></html
+>
=====================================
utils/haddock/html-test/src/T27727.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
+
+module T27727 (demonstration, f) where
+
+import Data.Kind (Type)
+import GHC.Exts (Int#, TYPE, RuntimeRep)
+
+demonstration :: forall (f :: forall r. TYPE r -> Type) . f Int# -> f Int#
+demonstration x = x
+
+data P :: RuntimeRep -> Type
+
+f :: (forall r. P r) -> P s
+f x = x
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcb7d61a4c3ec0fb738c23e54346b0b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcb7d61a4c3ec0fb738c23e54346b0b…
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] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 23 Aug '26
by Marge Bot (＠marge-bot) 23 Aug '26
23 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
312547b7 by Andreas Klebinger at 2026-08-23T16:17:50-04:00
rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
We accidentally operated over `uint64_t*` when we should use `uint8_t`.
Fixes #27569
- - - - -
e54da4bb by Alan Zimmerman at 2026-08-23T16:17:51-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
- - - - -
6 changed files:
- rts/linker/elf_reloc_riscv64.c
- 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:
=====================================
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,
=====================================
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/63fc04560835be2a6655fc15b7cc93…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63fc04560835be2a6655fc15b7cc93…
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
23 Aug '26
Cheng Shao deleted branch wip/split-sections-scc at Glasgow Haskell Compiler / GHC
--
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] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 23 Aug '26
by Marge Bot (＠marge-bot) 23 Aug '26
23 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9e5aa11f by Andreas Klebinger at 2026-08-23T12:10:27-04:00
rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
We accidentally operated over `uint64_t*` when we should use `uint8_t`.
Fixes #27569
- - - - -
63fc0456 by Alan Zimmerman at 2026-08-23T12:10:28-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
- - - - -
6 changed files:
- rts/linker/elf_reloc_riscv64.c
- 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:
=====================================
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,
=====================================
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/57b559a94bbf643b7f894e8600cc51…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57b559a94bbf643b7f894e8600cc51…
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
23 Aug '26
Krzysztof Gogolewski pushed new branch wip/T27727 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T27727
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