[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: AArch64: Remove unused instructions
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Nov 20 12:12:12 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
856e0a4e by Sven Tennie at 2023-11-18T06:54:11-05:00
AArch64: Remove unused instructions
As these aren't ever emitted, we don't even know if they work or will
ever be used. If one of them is needed in future, we may easily re-add
it.
Deleted instructions are:
- CMN
- ANDS
- BIC
- BICS
- EON
- ORN
- ROR
- TST
- STP
- LDP
- DMBSY
- - - - -
615441ef by Alan Zimmerman at 2023-11-18T06:54:46-05:00
EPA: Replace Monoid with NoAnn
Remove the final Monoid instances in the exact print infrastructure.
For Windows CI
Metric Decrease:
T5205
- - - - -
8bde6c36 by Alan Zimmerman at 2023-11-19T14:29:48+00:00
EPA: Use SrcSpan in EpaSpan
This is more natural, since we already need to deal with invalid
RealSrcSpans, and that is exactly what SrcSpan.UnhelpfulSpan is for.
Updates haddock submodule.
- - - - -
e866b16b by Sebastian Graf at 2023-11-20T07:11:42-05:00
Add regression test for #6070
Fixes #6070.
- - - - -
19 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/printer/Test20297.stdout
- + testsuite/tests/stranal/sigs/T6070.hs
- + testsuite/tests/stranal/sigs/T6070.stderr
- testsuite/tests/stranal/sigs/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Orphans.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -434,7 +434,7 @@ getMovWideImm n w
-- | Arithmetic(immediate)
-- Allows for 12bit immediates which can be shifted by 0 or 12 bits.
--- Used with ADD, ADDS, SUB, SUBS, CMP, CMN
+-- Used with ADD, ADDS, SUB, SUBS, CMP
-- See Note [Aarch64 immediates]
getArithImm :: Integer -> Width -> Maybe Operand
getArithImm n w
@@ -459,7 +459,7 @@ getArithImm n w
-- | Logical (immediate)
-- Allows encoding of some repeated bitpatterns
--- Used with AND, ANDS, EOR, ORR, TST
+-- Used with AND, EOR, ORR
-- and their aliases which includes at least MOV (bitmask immediate)
-- See Note [Aarch64 immediates]
getBitmaskImm :: Integer -> Width -> Maybe Operand
=====================================
compiler/GHC/CmmToAsm/AArch64/Instr.hs
=====================================
@@ -79,7 +79,6 @@ regUsageOfInstr platform instr = case instr of
-- 1. Arithmetic Instructions ------------------------------------------------
ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
- CMN l r -> usage (regOp l ++ regOp r, [])
CMP l r -> usage (regOp l ++ regOp r, [])
MSUB dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)
MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
@@ -102,9 +101,6 @@ regUsageOfInstr platform instr = case instr of
-- 3. Logical and Move Instructions ------------------------------------------
AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
ASR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
- BIC dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
- BICS dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
- EON dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
EOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
LSL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
LSR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
@@ -113,8 +109,6 @@ regUsageOfInstr platform instr = case instr of
MOVZ dst src -> usage (regOp src, regOp dst)
MVN dst src -> usage (regOp src, regOp dst)
ORR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
- ROR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
- TST src1 src2 -> usage (regOp src1 ++ regOp src2, [])
-- 4. Branch Instructions ----------------------------------------------------
J t -> usage (regTarget t, [])
B t -> usage (regTarget t, [])
@@ -131,12 +125,8 @@ regUsageOfInstr platform instr = case instr of
STLR _ src dst -> usage (regOp src ++ regOp dst, [])
LDR _ dst src -> usage (regOp src, regOp dst)
LDAR _ dst src -> usage (regOp src, regOp dst)
- -- TODO is this right? see STR, which I'm only partial about being right?
- STP _ src1 src2 dst -> usage (regOp src1 ++ regOp src2 ++ regOp dst, [])
- LDP _ dst1 dst2 src -> usage (regOp src, regOp dst1 ++ regOp dst2)
-- 8. Synchronization Instructions -------------------------------------------
- DMBSY -> usage ([], [])
DMBISH -> usage ([], [])
-- 9. Floating Point Instructions --------------------------------------------
@@ -219,7 +209,6 @@ patchRegsOfInstr instr env = case instr of
DELTA{} -> instr
-- 1. Arithmetic Instructions ----------------------------------------------
ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3)
- CMN o1 o2 -> CMN (patchOp o1) (patchOp o2)
CMP o1 o2 -> CMP (patchOp o1) (patchOp o2)
MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3)
@@ -242,11 +231,7 @@ patchRegsOfInstr instr env = case instr of
-- 3. Logical and Move Instructions ----------------------------------------
AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3)
- ANDS o1 o2 o3 -> ANDS (patchOp o1) (patchOp o2) (patchOp o3)
ASR o1 o2 o3 -> ASR (patchOp o1) (patchOp o2) (patchOp o3)
- BIC o1 o2 o3 -> BIC (patchOp o1) (patchOp o2) (patchOp o3)
- BICS o1 o2 o3 -> BICS (patchOp o1) (patchOp o2) (patchOp o3)
- EON o1 o2 o3 -> EON (patchOp o1) (patchOp o2) (patchOp o3)
EOR o1 o2 o3 -> EOR (patchOp o1) (patchOp o2) (patchOp o3)
LSL o1 o2 o3 -> LSL (patchOp o1) (patchOp o2) (patchOp o3)
LSR o1 o2 o3 -> LSR (patchOp o1) (patchOp o2) (patchOp o3)
@@ -255,8 +240,6 @@ patchRegsOfInstr instr env = case instr of
MOVZ o1 o2 -> MOVZ (patchOp o1) (patchOp o2)
MVN o1 o2 -> MVN (patchOp o1) (patchOp o2)
ORR o1 o2 o3 -> ORR (patchOp o1) (patchOp o2) (patchOp o3)
- ROR o1 o2 o3 -> ROR (patchOp o1) (patchOp o2) (patchOp o3)
- TST o1 o2 -> TST (patchOp o1) (patchOp o2)
-- 4. Branch Instructions --------------------------------------------------
J t -> J (patchTarget t)
@@ -274,11 +257,8 @@ patchRegsOfInstr instr env = case instr of
STLR f o1 o2 -> STLR f (patchOp o1) (patchOp o2)
LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2)
LDAR f o1 o2 -> LDAR f (patchOp o1) (patchOp o2)
- STP f o1 o2 o3 -> STP f (patchOp o1) (patchOp o2) (patchOp o3)
- LDP f o1 o2 o3 -> LDP f (patchOp o1) (patchOp o2) (patchOp o3)
-- 8. Synchronization Instructions -----------------------------------------
- DMBSY -> DMBSY
DMBISH -> DMBISH
-- 9. Floating Point Instructions ------------------------------------------
@@ -560,7 +540,6 @@ data Instr
-- | ADDS Operand Operand Operand -- rd = rn + rm
-- | ADR ...
-- | ADRP ...
- | CMN Operand Operand -- rd + op2
| CMP Operand Operand -- rd - op2
-- | MADD ...
-- | MNEG ...
@@ -601,11 +580,7 @@ data Instr
-- 3. Logical and Move Instructions ----------------------------------------
| AND Operand Operand Operand -- rd = rn & op2
- | ANDS Operand Operand Operand -- rd = rn & op2
| ASR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits
- | BIC Operand Operand Operand -- rd = rn & ~op2
- | BICS Operand Operand Operand -- rd = rn & ~op2
- | EON Operand Operand Operand -- rd = rn ⊕ ~op2
| EOR Operand Operand Operand -- rd = rn ⊕ op2
| LSL Operand Operand Operand -- rd = rn ≪ rm or rd = rn ≪ #i, i is 6 bits
| LSR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits
@@ -614,18 +589,13 @@ data Instr
-- | MOVN Operand Operand
| MOVZ Operand Operand
| MVN Operand Operand -- rd = ~rn
- | ORN Operand Operand Operand -- rd = rn | ~op2
| ORR Operand Operand Operand -- rd = rn | op2
- | ROR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits
- | TST Operand Operand -- rn & op2
-- Load and stores.
-- TODO STR/LDR might want to change to STP/LDP with XZR for the second register.
| STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr
| STLR Format Operand Operand -- stlr Xn, address-mode // Xn -> *addr
| LDR Format Operand Operand -- ldr Xn, address-mode // Xn <- *addr
| LDAR Format Operand Operand -- ldar Xn, address-mode // Xn <- *addr
- | STP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn -> *addr, Xm -> *(addr + 8)
- | LDP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn <- *addr, Xm <- *(addr + 8)
-- Conditional instructions
| CSET Operand Cond -- if(cond) op <- 1 else op <- 0
@@ -639,7 +609,6 @@ data Instr
| BCOND Cond Target -- branch with condition. b.<cond>
-- 8. Synchronization Instructions -----------------------------------------
- | DMBSY
| DMBISH
-- 9. Floating Point Instructions
-- Float ConVerT
@@ -675,7 +644,6 @@ instrCon i =
PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"
POP_STACK_FRAME{} -> "POP_STACK_FRAME"
ADD{} -> "ADD"
- CMN{} -> "CMN"
CMP{} -> "CMP"
MSUB{} -> "MSUB"
MUL{} -> "MUL"
@@ -690,11 +658,7 @@ instrCon i =
SBFX{} -> "SBFX"
UBFX{} -> "UBFX"
AND{} -> "AND"
- ANDS{} -> "ANDS"
ASR{} -> "ASR"
- BIC{} -> "BIC"
- BICS{} -> "BICS"
- EON{} -> "EON"
EOR{} -> "EOR"
LSL{} -> "LSL"
LSR{} -> "LSR"
@@ -702,16 +666,11 @@ instrCon i =
MOVK{} -> "MOVK"
MOVZ{} -> "MOVZ"
MVN{} -> "MVN"
- ORN{} -> "ORN"
ORR{} -> "ORR"
- ROR{} -> "ROR"
- TST{} -> "TST"
STR{} -> "STR"
STLR{} -> "STLR"
LDR{} -> "LDR"
LDAR{} -> "LDAR"
- STP{} -> "STP"
- LDP{} -> "LDP"
CSET{} -> "CSET"
CBZ{} -> "CBZ"
CBNZ{} -> "CBNZ"
@@ -719,7 +678,6 @@ instrCon i =
B{} -> "B"
BL{} -> "BL"
BCOND{} -> "BCOND"
- DMBSY{} -> "DMBSY"
DMBISH{} -> "DMBISH"
FCVT{} -> "FCVT"
SCVTF{} -> "SCVTF"
=====================================
compiler/GHC/CmmToAsm/AArch64/Ppr.hs
=====================================
@@ -370,7 +370,6 @@ pprInstr platform instr = case instr of
ADD o1 o2 o3
| isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd") o1 o2 o3
| otherwise -> op3 (text "\tadd") o1 o2 o3
- CMN o1 o2 -> op2 (text "\tcmn") o1 o2
CMP o1 o2
| isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2
| otherwise -> op2 (text "\tcmp") o1 o2
@@ -405,11 +404,7 @@ pprInstr platform instr = case instr of
-- 3. Logical and Move Instructions ------------------------------------------
AND o1 o2 o3 -> op3 (text "\tand") o1 o2 o3
- ANDS o1 o2 o3 -> op3 (text "\tands") o1 o2 o3
ASR o1 o2 o3 -> op3 (text "\tasr") o1 o2 o3
- BIC o1 o2 o3 -> op3 (text "\tbic") o1 o2 o3
- BICS o1 o2 o3 -> op3 (text "\tbics") o1 o2 o3
- EON o1 o2 o3 -> op3 (text "\teon") o1 o2 o3
EOR o1 o2 o3 -> op3 (text "\teor") o1 o2 o3
LSL o1 o2 o3 -> op3 (text "\tlsl") o1 o2 o3
LSR o1 o2 o3 -> op3 (text "\tlsr") o1 o2 o3
@@ -419,10 +414,7 @@ pprInstr platform instr = case instr of
MOVK o1 o2 -> op2 (text "\tmovk") o1 o2
MOVZ o1 o2 -> op2 (text "\tmovz") o1 o2
MVN o1 o2 -> op2 (text "\tmvn") o1 o2
- ORN o1 o2 o3 -> op3 (text "\torn") o1 o2 o3
ORR o1 o2 o3 -> op3 (text "\torr") o1 o2 o3
- ROR o1 o2 o3 -> op3 (text "\tror") o1 o2 o3
- TST o1 o2 -> op2 (text "\ttst") o1 o2
-- 4. Branch Instructions ----------------------------------------------------
J t -> pprInstr platform (B t)
@@ -526,12 +518,9 @@ pprInstr platform instr = case instr of
LDR _f o1 o2 -> op2 (text "\tldr") o1 o2
LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2
- STP _f o1 o2 o3 -> op3 (text "\tstp") o1 o2 o3
- LDP _f o1 o2 o3 -> op3 (text "\tldp") o1 o2 o3
-
-- 8. Synchronization Instructions -------------------------------------------
- DMBSY -> line $ text "\tdmb sy"
DMBISH -> line $ text "\tdmb ish"
+
-- 9. Floating Point Instructions --------------------------------------------
FCVT o1 o2 -> op2 (text "\tfcvt") o1 o2
SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -144,7 +144,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
_ -> parens $ text "SourceText" <+> text "blanked"
epaAnchor :: EpaLocation -> SDoc
- epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r
+ epaAnchor (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s
epaAnchor (EpaDelta d cs) = case ba of
NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs
BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"
=====================================
compiler/GHC/Hs/ImpExp.hs
=====================================
@@ -42,6 +42,7 @@ import GHC.Unit.Module.Warnings
import Data.Data
import Data.Maybe
+import qualified Data.Semigroup as Semigroup
{-
@@ -119,6 +120,13 @@ data EpAnnImportDecl = EpAnnImportDecl
, importDeclAnnAs :: Maybe EpaLocation
} deriving (Data)
+instance Semigroup EpAnnImportDecl where
+ EpAnnImportDecl a1 b1 c1 d1 e1 f1 <> EpAnnImportDecl a2 b2 c2 d2 e2 f2
+ = EpAnnImportDecl (a1 Semigroup.<> a2) (b1 Semigroup.<> b2) (c1 Semigroup.<> c2)
+ (d1 Semigroup.<> d2) (e1 Semigroup.<> e2) (f1 Semigroup.<> f2)
+instance Monoid EpAnnImportDecl where
+ mempty = EpAnnImportDecl noSpanAnchor Nothing Nothing Nothing Nothing Nothing
+
-- ---------------------------------------------------------------------
simpleImportDecl :: ModuleName -> ImportDecl GhcPs
=====================================
compiler/GHC/Parser.y
=====================================
@@ -4308,7 +4308,7 @@ glRR :: Located a -> RealSrcSpan
glRR = realSrcSpan . getLoc
glR :: HasLoc a => a -> Anchor
-glR la = EpaSpan (realSrcSpan $ getHasLoc la) Strict.Nothing
+glR la = EpaSpan (getHasLoc la)
glMR :: Maybe (Located a) -> Located b -> Anchor
glMR (Just la) _ = glR la
@@ -4318,7 +4318,7 @@ glEE :: (HasLoc a, HasLoc b) => a -> b -> Anchor
glEE x y = spanAsAnchor $ comb2 x y
anc :: RealSrcSpan -> Anchor
-anc r = EpaSpan r Strict.Nothing
+anc r = EpaSpan (RealSrcSpan r Strict.Nothing)
glRM :: Located a -> Maybe Anchor
glRM (L l _) = Just $ spanAsAnchor l
@@ -4442,7 +4442,7 @@ parseSignature :: P (Located (HsModule GhcPs))
parseSignature = parseSignatureNoHaddock >>= addHaddockToModule
commentsA :: (NoAnn ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)
-commentsA loc cs = SrcSpanAnn (EpAnn (EpaSpan (rs loc) Strict.Nothing) noAnn cs) loc
+commentsA loc cs = SrcSpanAnn (EpAnn (EpaSpan loc) noAnn cs) loc
-- | Instead of getting the *enclosed* comments, this includes the
-- *preceding* ones. It is used at the top level to get comments
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -406,7 +406,7 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
-- in the @'EpaDelta'@ variant captures any comments between the prior
-- output and the thing being marked here, since we cannot otherwise
-- sort the relative order.
-data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)
+data EpaLocation = EpaSpan !SrcSpan
| EpaDelta !DeltaPos ![LEpaComment]
deriving (Data,Eq,Show)
@@ -418,7 +418,7 @@ data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation
getTokenSrcSpan :: TokenLocation -> SrcSpan
getTokenSrcSpan NoTokenLoc = noSrcSpan
getTokenSrcSpan (TokenLoc EpaDelta{}) = noSrcSpan
-getTokenSrcSpan (TokenLoc (EpaSpan rspan mbufpos)) = RealSrcSpan rspan mbufpos
+getTokenSrcSpan (TokenLoc (EpaSpan span)) = span
instance Outputable a => Outputable (GenLocated TokenLocation a) where
ppr (L _ x) = ppr x
@@ -455,15 +455,15 @@ getDeltaLine (DifferentLine r _) = r
-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the
-- partial function is safe.
epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan
-epaLocationRealSrcSpan (EpaSpan r _) = r
-epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan"
+epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r
+epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan"
epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation
-epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing
-epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing
+epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan l
+epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = anc
instance Outputable EpaLocation where
- ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r
+ ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
instance Outputable AddEpAnn where
@@ -527,18 +527,17 @@ data EpAnn ann
type Anchor = EpaLocation -- Transitional
anchor :: Anchor -> RealSrcSpan
-anchor (EpaSpan r _) = r
+anchor (EpaSpan (RealSrcSpan r _)) = r
anchor _ = panic "anchor"
spanAsAnchor :: SrcSpan -> Anchor
-spanAsAnchor (RealSrcSpan r mb) = EpaSpan r mb
-spanAsAnchor s = EpaSpan (realSrcSpan s) Strict.Nothing
+spanAsAnchor ss = EpaSpan ss
realSpanAsAnchor :: RealSrcSpan -> Anchor
-realSpanAsAnchor r = EpaSpan r Strict.Nothing
+realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing)
spanFromAnchor :: Anchor -> SrcSpan
-spanFromAnchor (EpaSpan r mb) = RealSrcSpan r mb
+spanFromAnchor (EpaSpan ss) = ss
spanFromAnchor (EpaDelta _ _) = UnhelpfulSpan (UnhelpfulOther (fsLit "spanFromAnchor"))
noSpanAnchor :: Anchor
@@ -1062,8 +1061,8 @@ realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary
l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1)
srcSpan2e :: SrcSpan -> EpaLocation
-srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb
-srcSpan2e span = EpaSpan (realSrcSpan span) Strict.Nothing
+srcSpan2e ss@(RealSrcSpan _ _) = EpaSpan ss
+srcSpan2e span = EpaSpan (RealSrcSpan (realSrcSpan span) Strict.Nothing)
la2e :: SrcSpanAnn' a -> EpaLocation
la2e = srcSpan2e . locA
@@ -1081,7 +1080,7 @@ reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e
reAnnL anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a
getLocAnn :: Located a -> SrcSpanAnnA
-getLocAnn (L l _) = SrcSpanAnn EpAnnNotUsed l
+getLocAnn (L l _) = SrcSpanAnn noAnn l
instance NoAnn (EpAnn a) where
-- Short form for 'EpAnnNotUsed'
@@ -1111,7 +1110,8 @@ widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan
widenSpan s as = foldl combineSrcSpans s (go as)
where
go [] = []
- go (AddEpAnn _ (EpaSpan s mb):rest) = RealSrcSpan s mb : go rest
+ go (AddEpAnn _ (EpaSpan (RealSrcSpan s mb)):rest) = RealSrcSpan s mb : go rest
+ go (AddEpAnn _ (EpaSpan _):rest) = go rest
go (AddEpAnn _ (EpaDelta _ _):rest) = go rest
-- | The annotations need to all come after the anchor. Make sure
@@ -1120,8 +1120,8 @@ widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan
widenRealSpan s as = foldl combineRealSrcSpans s (go as)
where
go [] = []
- go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest
- go (AddEpAnn _ (EpaDelta _ _):rest) = go rest
+ go (AddEpAnn _ (EpaSpan (RealSrcSpan s _)):rest) = s : go rest
+ go (AddEpAnn _ _:rest) = go rest
realSpanFromAnns :: [AddEpAnn] -> Strict.Maybe RealSrcSpan
realSpanFromAnns as = go Strict.Nothing as
@@ -1130,7 +1130,7 @@ realSpanFromAnns as = go Strict.Nothing as
combine (Strict.Just l) r = Strict.Just $ combineRealSrcSpans l r
go acc [] = acc
- go acc (AddEpAnn _ (EpaSpan s _b):rest) = go (combine acc s) rest
+ go acc (AddEpAnn _ (EpaSpan (RealSrcSpan s _b)):rest) = go (combine acc s) rest
go acc (AddEpAnn _ _ :rest) = go acc rest
bufSpanFromAnns :: [AddEpAnn] -> Strict.Maybe BufSpan
@@ -1140,28 +1140,27 @@ bufSpanFromAnns as = go Strict.Nothing as
combine (Strict.Just l) r = Strict.Just $ combineBufSpans l r
go acc [] = acc
- go acc (AddEpAnn _ (EpaSpan _ (Strict.Just mb)):rest) = go (combine acc mb) rest
+ go acc (AddEpAnn _ (EpaSpan (RealSrcSpan _ (Strict.Just mb))):rest) = go (combine acc mb) rest
go acc (AddEpAnn _ _:rest) = go acc rest
--- widenAnchor :: Anchor -> [AddEpAnn] -> Anchor
--- widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op
widenAnchor :: Anchor -> [AddEpAnn] -> Anchor
-widenAnchor (EpaSpan s mb) as
- = EpaSpan (widenRealSpan s as) (liftA2 combineBufSpans mb (bufSpanFromAnns as))
--- widenAnchor (EpaSpan r mb) _ = EpaSpan r mb
+widenAnchor (EpaSpan (RealSrcSpan s mb)) as
+ = EpaSpan (RealSrcSpan (widenRealSpan s as) (liftA2 combineBufSpans mb (bufSpanFromAnns as)))
+widenAnchor (EpaSpan us) _ = EpaSpan us
widenAnchor a@(EpaDelta _ _) as = case (realSpanFromAnns as) of
Strict.Nothing -> a
- Strict.Just r -> EpaSpan r Strict.Nothing
+ Strict.Just r -> EpaSpan (RealSrcSpan r Strict.Nothing)
widenAnchorR :: Anchor -> RealSrcSpan -> Anchor
-widenAnchorR (EpaSpan s _) r = EpaSpan (combineRealSrcSpans s r) Strict.Nothing
-widenAnchorR (EpaDelta _ _) r = EpaSpan r Strict.Nothing
+widenAnchorR (EpaSpan (RealSrcSpan s _)) r = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) Strict.Nothing)
+widenAnchorR (EpaSpan _) r = EpaSpan (RealSrcSpan r Strict.Nothing)
+widenAnchorR (EpaDelta _ _) r = EpaSpan (RealSrcSpan r Strict.Nothing)
widenAnchorS :: Anchor -> SrcSpan -> Anchor
-widenAnchorS (EpaSpan s mbe) (RealSrcSpan r mbr)
- = EpaSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr)
-widenAnchorS (EpaSpan us mb) _ = EpaSpan us mb
-widenAnchorS (EpaDelta _ _) (RealSrcSpan r mb) = EpaSpan r mb
+widenAnchorS (EpaSpan (RealSrcSpan s mbe)) (RealSrcSpan r mbr)
+ = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr))
+widenAnchorS (EpaSpan us) _ = EpaSpan us
+widenAnchorS (EpaDelta _ _) (RealSrcSpan r mb) = EpaSpan (RealSrcSpan r mb)
widenAnchorS anc _ = anc
widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an
@@ -1251,7 +1250,7 @@ placeholderRealSpan :: RealSrcSpan
placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1))
comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO
-comment loc cs = EpAnn (EpaSpan loc Strict.Nothing) NoEpAnns cs
+comment loc cs = EpAnn (EpaSpan (RealSrcSpan loc Strict.Nothing)) NoEpAnns cs
-- ---------------------------------------------------------------------
-- Utilities for managing comments in an `EpAnn a` structure.
@@ -1393,10 +1392,10 @@ instance (Semigroup a) => Semigroup (EpAnn a) where
-- annotations must follow it. So we combine them which yields the
-- largest span
-instance Semigroup Anchor where
- EpaSpan s1 m1 <> EpaSpan s2 m2 = EpaSpan (combineRealSrcSpans s1 s2) (liftA2 combineBufSpans m1 m2)
- EpaSpan s1 m1 <> _ = EpaSpan s1 m1
- _ <> EpaSpan s2 m2 = EpaSpan s2 m2
+instance Semigroup EpaLocation where
+ EpaSpan s1 <> EpaSpan s2 = EpaSpan (combineSrcSpans s1 s2)
+ EpaSpan s1 <> _ = EpaSpan s1
+ _ <> EpaSpan s2 = EpaSpan s2
EpaDelta dp1 cs1 <> EpaDelta _dp2 cs2 = EpaDelta dp1 (cs1<>cs2)
instance Semigroup EpAnnComments where
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -3780,7 +3780,8 @@ warn_unknown_prag prags span buf len buf2 = do
-- 'AddEpAnn' values for the opening and closing bordering on the start
-- and end of the span
mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)
-mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCloseP (EpaSpan lc Strict.Nothing))
+mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan (RealSrcSpan lo Strict.Nothing)),
+ AddEpAnn AnnCloseP (EpaSpan (RealSrcSpan lc Strict.Nothing)))
where
f = srcSpanFile ss
sl = srcSpanStartLine ss
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -472,29 +472,30 @@ annBinds a cs (HsIPBinds an bs) = (HsIPBinds (add_where a an cs) bs, Nothing)
annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)
add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
-add_where an@(AddEpAnn _ (EpaSpan rs _)) (EpAnn a (AnnList anc o c r t) cs) cs2
- | valid_anchor (anchor a)
+add_where an@(AddEpAnn _ (EpaSpan (RealSrcSpan rs _))) (EpAnn a (AnnList anc o c r t) cs) cs2
+ | valid_anchor a
= EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2)
| otherwise
= EpAnn (patch_anchor rs a)
(AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)
-add_where an@(AddEpAnn _ (EpaSpan rs mb)) EpAnnNotUsed cs
- = EpAnn (EpaSpan rs mb)
- (AnnList (Just $ EpaSpan rs mb) Nothing Nothing [an] []) cs
+add_where an@(AddEpAnn _ (EpaSpan (RealSrcSpan rs mb))) EpAnnNotUsed cs
+ = EpAnn (EpaSpan (RealSrcSpan rs mb))
+ (AnnList (Just $ EpaSpan (RealSrcSpan rs mb)) Nothing Nothing [an] []) cs
add_where (AddEpAnn _ _) _ _ = panic "add_where"
-- EpaDelta should only be used for transformations
-valid_anchor :: RealSrcSpan -> Bool
-valid_anchor r = srcSpanStartLine r >= 0
+valid_anchor :: Anchor -> Bool
+valid_anchor (EpaSpan (RealSrcSpan r _)) = srcSpanStartLine r >= 0
+valid_anchor _ = False
-- If the decl list for where binds is empty, the anchor ends up
-- invalid. In this case, use the parent one
patch_anchor :: RealSrcSpan -> Anchor -> Anchor
-patch_anchor r (EpaDelta _ _) = EpaSpan r Strict.Nothing
-patch_anchor r1 (EpaSpan r0 mb) = EpaSpan r mb
+patch_anchor r (EpaDelta _ _) = EpaSpan (RealSrcSpan r Strict.Nothing)
+patch_anchor r1 (EpaSpan (RealSrcSpan r0 mb)) = EpaSpan (RealSrcSpan r mb)
where
r = if srcSpanStartLine r0 < 0 then r1 else r0
--- patch_anchor _ (EpaSpan ss mb) = EpaSpan ss mb
+patch_anchor _ (EpaSpan ss) = EpaSpan ss
fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList
fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed
@@ -504,9 +505,9 @@ fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)
-- | The 'Anchor' for a stmtlist is based on either the location or
-- the first semicolon annotion.
stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe Anchor
-stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (AddEpAnn _ (EpaSpan r rb)) _), _))
- = Just $ widenAnchorS (EpaSpan l mb) (RealSrcSpan r rb)
-stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan l mb
+stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (AddEpAnn _ (EpaSpan (RealSrcSpan r rb))) _), _))
+ = Just $ widenAnchorS (EpaSpan (RealSrcSpan l mb)) (RealSrcSpan r rb)
+stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan (RealSrcSpan l mb)
stmtsAnchor _ = Nothing
stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan
@@ -994,7 +995,7 @@ checkTyVars pp_what equals_or_where tc tparms
for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) [])
for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn]
- for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan r _mb)) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments
+ for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan (RealSrcSpan r _mb))) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments
for_widening_ann _ = EpAnnNotUsed
@@ -1111,14 +1112,14 @@ checkTyClHdr is_cls ty
newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =
let
lr = combineRealSrcSpans (realSrcSpan l) (anchor as)
- an = (EpAnn (EpaSpan lr Strict.Nothing) (NameAnn NameParens o (srcSpan2e l) c []) cs)
+ an = EpAnn (EpaSpan (RealSrcSpan lr Strict.Nothing)) (NameAnn NameParens o (srcSpan2e l) c []) cs
in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
newAnns _ EpAnnNotUsed = panic "missing AnnParen"
newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =
let
- lr = combineRealSrcSpans (anchor ap) (anchor as)
- an = (EpAnn (EpaSpan lr Strict.Nothing) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs))
- in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
+ lr = RealSrcSpan (combineRealSrcSpans (anchor ap) (anchor as)) Strict.Nothing
+ an = EpAnn (EpaSpan lr) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs)
+ in SrcSpanAnn an lr
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
@@ -3210,14 +3211,14 @@ mkMultTy pct t arr = HsExplicitMult pct t arr
mkTokenLocation :: SrcSpan -> TokenLocation
mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc
-mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb)
+mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan (RealSrcSpan r mb))
-- Precondition: the TokenLocation has EpaSpan, never EpaDelta.
token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation
token_location_widenR NoTokenLoc _ = NoTokenLoc
token_location_widenR tl (UnhelpfulSpan _) = tl
-token_location_widenR (TokenLoc (EpaSpan r1 mb1)) (RealSrcSpan r2 mb2) =
- (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2) (liftA2 combineBufSpans mb1 mb2)))
+token_location_widenR (TokenLoc (EpaSpan s1)) s2 =
+ (TokenLoc (EpaSpan (combineSrcSpans s1 s2)))
token_location_widenR (TokenLoc (EpaDelta _ _)) _ =
-- Never happens because the parser does not produce EpaDelta.
panic "token_location_widenR: EpaDelta"
=====================================
testsuite/tests/printer/Test20297.stdout
=====================================
@@ -99,10 +99,10 @@
{OccName: x}))))))]
(HsValBinds
(EpAnn
- (EpaSpan { Test20297.hs:7:3-7 })
+ (EpaSpan { <no location info> })
(AnnList
(Just
- (EpaSpan { Test20297.hs:7:3-7 }))
+ (EpaSpan { <no location info> }))
(Nothing)
(Nothing)
[(AddEpAnn AnnWhere (EpaSpan { Test20297.hs:7:3-7 }))]
@@ -390,10 +390,10 @@
{OccName: x}))))))]
(HsValBinds
(EpAnn
- (EpaSpan { Test20297.ppr.hs:5:3-7 })
+ (EpaSpan { <no location info> })
(AnnList
(Just
- (EpaSpan { Test20297.ppr.hs:5:3-7 }))
+ (EpaSpan { <no location info> }))
(Nothing)
(Nothing)
[(AddEpAnn AnnWhere (EpaSpan { Test20297.ppr.hs:5:3-7 }))]
=====================================
testsuite/tests/stranal/sigs/T6070.hs
=====================================
@@ -0,0 +1,13 @@
+module T6070 where
+
+import qualified Data.Map as M
+
+-- Should unbox `x`, so signature 1!P(..,..)
+h :: (Int, Int) -> Int -> (Int, Int)
+h x y = if y > 10
+ then x
+ else h (case h x 0 of (y1, y2) -> (y2, y1)) (y + 1)
+
+-- Should unbox `(a,b)`, so signature 1!P(..,..)
+c :: M.Map Int Int -> (Int, Int)
+c m = M.foldrWithKey (\k v (a, b) -> if k + v > 2 then (a, b) else (b, a)) (0, 1) m
=====================================
testsuite/tests/stranal/sigs/T6070.stderr
=====================================
@@ -0,0 +1,18 @@
+
+==================== Strictness signatures ====================
+T6070.c: <1L>
+T6070.h: <1!P(L,L)><1!P(L)>
+
+
+
+==================== Cpr signatures ====================
+T6070.c: 1
+T6070.h: 1
+
+
+
+==================== Strictness signatures ====================
+T6070.c: <1L>
+T6070.h: <1!P(L,L)><1!P(L)>
+
+
=====================================
testsuite/tests/stranal/sigs/all.T
=====================================
@@ -18,6 +18,7 @@ test('DmdAnalGADTs', normal, compile, [''])
test('T12370', normal, compile, [''])
test('NewtypeArity', normal, compile, [''])
test('T5075', normal, compile, [''])
+test('T6070', normal, compile, [''])
test('T17932', normal, compile, [''])
test('T13380c', expect_broken('!3014'), compile, [''])
test('T13380f', normal, compile, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -422,7 +422,7 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
debugM $ "enterAnn:starting:(p,pe,anchor',a) =" ++ show (p, pe0, showAst anchor', astId a)
prevAnchor <- getAnchorU
let curAnchor = case anchor' of
- EpaSpan r _ -> r
+ EpaSpan (RealSrcSpan r _) -> r
_ -> prevAnchor
debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor)
case canUpdateAnchor of
@@ -495,10 +495,11 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
Just (EpaDelta dp _) -> dp
-- Replace original with desired one. Allows all
-- list entry values to be DP (1,0)
- Just (EpaSpan r _) -> dp
+ Just (EpaSpan (RealSrcSpan r _)) -> dp
where
dp = adjustDeltaForOffset
off (ss2delta priorEndAfterComments r)
+ Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r
-- ---------------------------------------------
-- Preparation complete, perform the action
when (priorEndAfterComments < spanStart) (do
@@ -543,9 +544,10 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
case anchor' of
EpaDelta _ _ -> return ()
- EpaSpan rss _ -> do
+ EpaSpan (RealSrcSpan rss _) -> do
setAcceptSpan False
setPriorEndD (snd $ rs2range rss)
+ EpaSpan _ -> return ()
-- Outside the anchor, mark any trailing
postCs <- cua canUpdateAnchor takeAppliedCommentsPop
@@ -723,7 +725,8 @@ printStringAtAAL (EpAnn anc an cs) l str = do
printStringAtAAC :: (Monad m, Monoid w)
=> CaptureComments -> EpaLocation -> String -> EP w m EpaLocation
-printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s
+printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s
+printStringAtAAC capture (EpaSpan (UnhelpfulSpan _)) s = printStringAtAAC capture (EpaDelta (SameLine 0) []) s
printStringAtAAC capture (EpaDelta d cs) s = do
mapM_ printOneComment $ concatMap tokComment cs
pe1 <- getPriorEndD
@@ -798,10 +801,10 @@ markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do
markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
=> Located (HsToken tok) -> EP w m (Located (HsToken tok))
markLToken (L (RealSrcSpan aa mb) t) = do
- epaLoc'<- printStringAtAA (EpaSpan aa mb) (symbolVal (Proxy @tok))
+ epaLoc'<- printStringAtAA (EpaSpan (RealSrcSpan aa mb)) (symbolVal (Proxy @tok))
case epaLoc' of
- EpaSpan aa' mb' -> return (L (RealSrcSpan aa' mb') t)
- _ -> return (L (RealSrcSpan aa mb ) t)
+ EpaSpan (RealSrcSpan aa' mb') -> return (L (RealSrcSpan aa' mb') t)
+ _ -> return (L (RealSrcSpan aa mb ) t)
markLToken (L lt t) = return (L lt t)
markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
@@ -1403,12 +1406,13 @@ printOneComment c@(Comment _str loc _r _mo) = do
debugM $ "printOneComment:c=" ++ showGhc c
dp <-case loc of
EpaDelta dp _ -> return dp
- EpaSpan r _ -> do
+ EpaSpan (RealSrcSpan r _) -> do
pe <- getPriorEndD
debugM $ "printOneComment:pe=" ++ showGhc pe
let dp = ss2delta pe r
debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc)
adjustDeltaForOffsetM dp
+ EpaSpan (UnhelpfulSpan _) -> return (SameLine 0)
mep <- getExtraDP
dp' <- case mep of
Just (EpaDelta edp _) -> do
@@ -1429,12 +1433,13 @@ updateAndApplyComment (Comment str anc pp mo) dp = do
(r,c) = ss2posEnd pp
dp'' = case anc of
EpaDelta dp1 _ -> dp1
- EpaSpan la _ ->
+ EpaSpan (RealSrcSpan la _) ->
if r == 0
then (ss2delta (r,c+0) la)
else (ss2delta (r,c) la)
+ EpaSpan (UnhelpfulSpan _) -> SameLine 0
dp' = case anc of
- EpaSpan r1 _ ->
+ EpaSpan (RealSrcSpan r1 _) ->
if pp == r1
then dp
else dp''
@@ -1459,7 +1464,7 @@ commentAllocationBefore ss = do
-- TODO: this is inefficient, use Pos all the way through
let (earlier,later) = partition (\(Comment _str loc _r _mo) ->
case loc of
- EpaSpan r _ -> (ss2pos r) <= (ss2pos ss)
+ EpaSpan (RealSrcSpan r _) -> (ss2pos r) <= (ss2pos ss)
_ -> True -- Choose one
) cs
putUnallocatedComments later
@@ -1475,7 +1480,7 @@ commentAllocationIn ss = do
-- TODO: this is inefficient, use Pos all the way through
let (earlier,later) = partition (\(Comment _str loc _r _mo) ->
case loc of
- EpaSpan r _ -> (ss2posEnd r) <= (ss2posEnd ss)
+ EpaSpan (RealSrcSpan r _) -> (ss2posEnd r) <= (ss2posEnd ss)
_ -> True -- Choose one
) cs
putUnallocatedComments later
@@ -4376,7 +4381,7 @@ printUnicode anc n = do
s -> s
loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str
case loc of
- EpaSpan _ _ -> return anc
+ EpaSpan _ -> return anc
EpaDelta dp [] -> return $ EpaDelta dp []
EpaDelta _ _cs -> error "printUnicode should not capture comments"
=====================================
utils/check-exact/Orphans.hs
=====================================
@@ -5,65 +5,61 @@ module Orphans where
import GHC hiding (EpaComment)
--- ---------------------------------------------------------------------
--- Orphan NoAnn instances. See https://gitlab.haskell.org/ghc/ghc/-/issues/20372
+-- -- ---------------------------------------------------------------------
instance NoAnn [a] where
noAnn = []
-instance NoAnn AnnPragma where
- noAnn = AnnPragma noAnn noAnn noAnn
-
-instance NoAnn EpAnnImportDecl where
- noAnn = EpAnnImportDecl noAnn Nothing Nothing Nothing Nothing Nothing
+instance (NoAnn a, NoAnn b) => NoAnn (a, b) where
+ noAnn = (noAnn, noAnn)
-instance NoAnn AnnParen where
- noAnn = AnnParen AnnParens noAnn noAnn
+instance NoAnn EpaLocation where
+ noAnn = EpaDelta (SameLine 0) []
-instance NoAnn HsRuleAnn where
- noAnn = HsRuleAnn Nothing Nothing noAnn
+instance NoAnn EpAnnSumPat where
+ noAnn = EpAnnSumPat [] [] []
-instance NoAnn AnnSig where
- noAnn = AnnSig noAnn noAnn
+instance NoAnn AnnPragma where
+ noAnn = AnnPragma noAnn noAnn []
-instance NoAnn GrhsAnn where
- noAnn = GrhsAnn Nothing noAnn
+instance NoAnn AddEpAnn where
+ noAnn = AddEpAnn noAnn noAnn
-instance NoAnn EpAnnUnboundVar where
- noAnn = EpAnnUnboundVar noAnn noAnn
+instance NoAnn AnnKeywordId where
+ noAnn = Annlarrowtail {- gotta pick one -}
-instance (NoAnn a, NoAnn b) => NoAnn (a, b) where
- noAnn = (noAnn, noAnn)
+instance NoAnn AnnParen where
+ noAnn = AnnParen AnnParens noAnn noAnn
-instance NoAnn AnnExplicitSum where
- noAnn = AnnExplicitSum noAnn noAnn noAnn noAnn
+instance NoAnn AnnsIf where
+ noAnn = AnnsIf noAnn noAnn noAnn Nothing Nothing
instance NoAnn EpAnnHsCase where
noAnn = EpAnnHsCase noAnn noAnn noAnn
-instance NoAnn AnnsIf where
- noAnn = AnnsIf noAnn noAnn noAnn noAnn noAnn
-
-instance NoAnn (Maybe a) where
- noAnn = Nothing
+instance NoAnn AnnFieldLabel where
+ noAnn = AnnFieldLabel Nothing
instance NoAnn AnnProjection where
noAnn = AnnProjection noAnn noAnn
-instance NoAnn AnnFieldLabel where
- noAnn = AnnFieldLabel Nothing
+instance NoAnn AnnExplicitSum where
+ noAnn = AnnExplicitSum noAnn noAnn noAnn noAnn
-instance NoAnn EpaLocation where
- noAnn = EpaDelta (SameLine 0) []
+instance NoAnn EpAnnUnboundVar where
+ noAnn = EpAnnUnboundVar noAnn noAnn
-instance NoAnn AddEpAnn where
- noAnn = AddEpAnn noAnn noAnn
+instance NoAnn GrhsAnn where
+ noAnn = GrhsAnn Nothing noAnn
-instance NoAnn AnnKeywordId where
- noAnn = Annlarrowtail {- gotta pick one -}
+instance NoAnn HsRuleAnn where
+ noAnn = HsRuleAnn Nothing Nothing noAnn
-instance NoAnn EpAnnSumPat where
- noAnn = EpAnnSumPat noAnn noAnn noAnn
+instance NoAnn AnnSig where
+ noAnn = AnnSig noAnn noAnn
+
+instance NoAnn EpAnnImportDecl where
+ noAnn = EpAnnImportDecl noAnn Nothing Nothing Nothing Nothing Nothing
instance NoAnn AnnsModule where
- noAnn = AnnsModule [] mempty Nothing
+ noAnn = AnnsModule [] [] Nothing
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -284,7 +284,7 @@ fixModuleTrailingComments (GHC.L l p) = GHC.L l p'
rebalance cs = cs'
where
cs' = case GHC.hsmodLayout $ GHC.hsmodExt p of
- GHC.ExplicitBraces _ (GHC.L (GHC.TokenLoc (GHC.EpaSpan ss _)) _) ->
+ GHC.ExplicitBraces _ (GHC.L (GHC.TokenLoc (GHC.EpaSpan (GHC.RealSrcSpan ss _))) _) ->
let
pc = GHC.priorComments cs
fc = GHC.getFollowingComments cs
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -222,8 +222,8 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll
L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor?
dc' = case dca of
- EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])
- EpaDelta _ _ -> AddEpAnn kw dca
+ EpaSpan (RealSrcSpan r _) -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])
+ _ -> AddEpAnn kw dca
-- ---------------------------------
@@ -232,7 +232,8 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
(L (SrcSpanAnn EpAnnNotUsed ll) b)
-> let
anc0 = case dca of
- EpaSpan r _ -> EpaDelta (ss2delta (ss2posEnd r) (realSrcSpan ll)) []
+ EpaSpan (RealSrcSpan r _) -> EpaDelta (ss2delta (ss2posEnd r) (realSrcSpan ll)) []
+ EpaSpan (UnhelpfulSpan _) -> EpaDelta (SameLine 1) []
EpaDelta _ cs0 -> EpaDelta (SameLine 1) cs0
in (L (SrcSpanAnn (EpAnn anc0 noAnn emptyComments) ll) b)
(L (SrcSpanAnn (EpAnn anc0 a c) ll) b)
@@ -240,7 +241,7 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
anc' = case anc0 of
EpaDelta _ _ -> anc0
_ -> case dca of
- EpaSpan _ _ -> EpaDelta (SameLine 1) []
+ EpaSpan _ -> EpaDelta (SameLine 1) []
EpaDelta _ cs0 -> EpaDelta (SameLine 1) cs0
in (L (SrcSpanAnn (EpAnn anc' a c) ll) b)
@@ -268,7 +269,11 @@ setEntryDP (L (SrcSpanAnn EpAnnNotUsed l) a) dp
= L (SrcSpanAnn
(EpAnn (EpaDelta dp []) noAnn emptyComments)
l) a
-setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan _ _) an (EpaComments [])) l) a) dp
+setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan (UnhelpfulSpan _)) an cs) l) a) dp
+ = L (SrcSpanAnn
+ (EpAnn (EpaDelta dp []) an cs)
+ l) a
+setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan _) an (EpaComments [])) l) a) dp
= L (SrcSpanAnn
(EpAnn (EpaDelta dp []) an (EpaComments []))
l) a
@@ -299,8 +304,8 @@ setEntryDP (L (SrcSpanAnn (EpAnn (EpaDelta d csd) an cs) l) a) dp
in
(dp0, c':t, EpaCommentsBalanced [] ts)
go (L (EpaDelta _ c0) c) = (d, L (EpaDelta dp c0) c)
- go (L (EpaSpan _ _) c) = (d, L (EpaDelta dp []) c)
-setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan r _) an cs) l) a) dp
+ go (L (EpaSpan _) c) = (d, L (EpaDelta dp []) c)
+setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) l) a) dp
= case sortEpaComments (priorComments cs) of
[] ->
L (SrcSpanAnn
@@ -315,8 +320,9 @@ setEntryDP (L (SrcSpanAnn (EpAnn (EpaSpan r _) an cs) l) a) dp
csd = L (EpaDelta dp []) c:cs'
lc = last $ (L ca c:cs')
delta = case getLoc lc of
- EpaSpan rr _ -> ss2delta (ss2pos rr) r
- EpaDelta _dp _ -> DifferentLine 1 0
+ EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r
+ EpaSpan _ -> (SameLine 0)
+ EpaDelta _ _ -> DifferentLine 1 0
-- cs'' = setPriorComments cs (L (EpaDelta dp []) c:cs')
-- lc = head $ reverse $ (L ca c:cs')
-- delta = case getLoc lc of
@@ -340,17 +346,20 @@ getEntryDP _ = SameLine 1
addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation
addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs
-addEpaLocationDelta off anc (EpaSpan r _)
+addEpaLocationDelta _off _anc s@(EpaSpan (UnhelpfulSpan _)) = s
+addEpaLocationDelta off anc (EpaSpan (RealSrcSpan r _))
= EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) []
-- Set the entry DP for an element coming after an existing keyword annotation
setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t
setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a
-setEntryDPFromAnchor off (EpaSpan anc _) ll@(L la _) = setEntryDP ll dp'
+setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a
+setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp'
where
dp' = case la of
(SrcSpanAnn EpAnnNotUsed l) -> adjustDeltaForOffset off (ss2deltaEnd anc (realSrcSpan l))
- (SrcSpanAnn (EpAnn (EpaSpan r' _) _ _) _) -> adjustDeltaForOffset off (ss2deltaEnd anc r')
+ (SrcSpanAnn (EpAnn (EpaSpan (RealSrcSpan r' _)) _ _) _) -> adjustDeltaForOffset off (ss2deltaEnd anc r')
+ (SrcSpanAnn (EpAnn (EpaSpan _) _ _) _) -> adjustDeltaForOffset off (SameLine 0)
(SrcSpanAnn (EpAnn (EpaDelta dp _) _ _) _) -> adjustDeltaForOffset off dp
-- ---------------------------------------------------------------------
@@ -381,7 +390,7 @@ transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 a
where
anc2' = case anc2 of
EpaDelta _ _ -> anc2
- EpaSpan _ _ -> EpaSpan (realSrcSpan l2) Strict.Nothing
+ EpaSpan _ -> EpaSpan (RealSrcSpan (realSrcSpan l2) Strict.Nothing)
-- |If a and b are the same type return first arg, else return second
@@ -447,7 +456,7 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do
-- + move the trailing ones to the last match.
let
(before,middle,after) = case s_entry lf of
- EpaSpan ss _ ->
+ EpaSpan (RealSrcSpan ss _) ->
let
split = splitCommentsEnd ss (s_comments lf)
split2 = splitCommentsStart ss (EpaComments (sortEpaComments $ priorComments split))
@@ -630,7 +639,7 @@ priorCommentsDeltas r cs = go r (reverse $ sortEpaComments cs)
splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
splitCommentsEnd p (EpaComments cs) = cs'
where
- cmp (L (EpaSpan l _) _) = ss2pos l > ss2posEnd p
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
cmp (L _ _) = True
(before, after) = break cmp cs
cs' = case after of
@@ -638,7 +647,7 @@ splitCommentsEnd p (EpaComments cs) = cs'
_ -> EpaCommentsBalanced before after
splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts'
where
- cmp (L (EpaSpan l _) _) = ss2pos l > ss2posEnd p
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
cmp (L _ _) = True
(before, after) = break cmp cs
cs' = before
@@ -649,7 +658,7 @@ splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts'
splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
splitCommentsStart p (EpaComments cs) = cs'
where
- cmp (L (EpaSpan l _) _) = ss2pos l > ss2posEnd p
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
cmp (L _ _) = True
(before, after) = break cmp cs
cs' = case after of
@@ -657,7 +666,7 @@ splitCommentsStart p (EpaComments cs) = cs'
_ -> EpaCommentsBalanced before after
splitCommentsStart p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts'
where
- cmp (L (EpaSpan l _) _) = ss2pos l > ss2posEnd p
+ cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
cmp (L _ _) = True
(before, after) = break cmp cs
cs' = before
@@ -933,7 +942,8 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
(L (TokenLoc l) ls, L (TokenLoc i) is) ->
let
off = case l of
- (EpaSpan r _) -> LayoutStartCol $ snd $ ss2pos r
+ (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r
+ (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0
(EpaDelta (SameLine _) _) -> LayoutStartCol 0
(EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c
ex'' = setEntryDPFromAnchor off i ex
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -123,7 +123,7 @@ undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc)
fc = co + dc
undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn
-undeltaSpan anc kw dp = AddEpAnn kw (EpaSpan sp Strict.Nothing)
+undeltaSpan anc kw dp = AddEpAnn kw (EpaSpan (RealSrcSpan sp Strict.Nothing))
where
(l,c) = undelta (ss2pos anc) dp (LayoutStartCol 0)
len = length (keywordToString kw)
@@ -170,7 +170,7 @@ spanLength = (-) <$> srcSpanEndCol <*> srcSpanStartCol
-- | Useful for debug dumps
eloc2str :: EpaLocation -> String
-eloc2str (EpaSpan r _) = "EpaSpan " ++ show (rs2range r)
+eloc2str (EpaSpan r) = "EpaSpan " ++ show (ss2range r)
eloc2str epaLoc = show epaLoc
-- ---------------------------------------------------------------------
@@ -186,7 +186,7 @@ isPointSrcSpan ss = spanLength ss == 0
-- `MovedAnchor` operation based on the original location, only if it
-- does not already have one.
commentOrigDelta :: LEpaComment -> LEpaComment
-commentOrigDelta (L (EpaSpan la _) (GHC.EpaComment t pp))
+commentOrigDelta (L (EpaSpan (RealSrcSpan la _)) (GHC.EpaComment t pp))
= (L (EpaDelta dp []) (GHC.EpaComment t pp))
`debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp))
where
@@ -331,8 +331,10 @@ sortEpaComments cs = sortBy cmp cs
-- | Makes a comment which originates from a specific keyword.
mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
-mkKWComment kw (EpaSpan ss mb)
- = Comment (keywordToString kw) (EpaSpan ss mb) ss (Just kw)
+mkKWComment kw (EpaSpan (RealSrcSpan ss mb))
+ = Comment (keywordToString kw) (EpaSpan (RealSrcSpan ss mb)) ss (Just kw)
+mkKWComment kw (EpaSpan (UnhelpfulSpan _))
+ = Comment (keywordToString kw) (EpaDelta (SameLine 0) []) placeholderRealSpan (Just kw)
mkKWComment kw (EpaDelta dp cs)
= Comment (keywordToString kw) (EpaDelta dp cs) placeholderRealSpan (Just kw)
@@ -444,15 +446,18 @@ To be absolutely sure, we make the delta versions use -ve values.
hackSrcSpanToAnchor :: SrcSpan -> Anchor
hackSrcSpanToAnchor (UnhelpfulSpan s) = error $ "hackSrcSpanToAnchor : UnhelpfulSpan:" ++ show s
-hackSrcSpanToAnchor (RealSrcSpan r Strict.Nothing) = EpaSpan r Strict.Nothing
-hackSrcSpanToAnchor (RealSrcSpan r mb@(Strict.Just (BufSpan (BufPos s) (BufPos e))))
- = if s <= 0 && e <= 0
- then EpaDelta (deltaPos (-s) (-e)) []
- `debug` ("hackSrcSpanToAnchor: (r,s,e)=" ++ showAst (r,s,e) )
- else EpaSpan r mb
+hackSrcSpanToAnchor (RealSrcSpan r mb)
+ = case mb of
+ (Strict.Just (BufSpan (BufPos s) (BufPos e))) ->
+ if s <= 0 && e <= 0
+ then EpaDelta (deltaPos (-s) (-e)) []
+ `debug` ("hackSrcSpanToAnchor: (r,s,e)=" ++ showAst (r,s,e) )
+ -- else Anchor r UnchangedAnchor
+ else EpaSpan (RealSrcSpan r mb)
+ _ -> EpaSpan (RealSrcSpan r mb)
hackAnchorToSrcSpan :: Anchor -> SrcSpan
-hackAnchorToSrcSpan (EpaSpan r mb) = RealSrcSpan r mb
+hackAnchorToSrcSpan (EpaSpan s) = s
hackAnchorToSrcSpan _ = error $ "hackAnchorToSrcSpan"
-- ---------------------------------------------------------------------
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit a70ba4918b8a65abd18b16f414b6e2c3c4e38c46
+Subproject commit 96e713f7768926dab4aeec5175c1854057a833c9
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64d8d36be9786186033e0e0ff94b9654f248b065...e866b16b101d1ff94127c72dff6cd4b93d81d216
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64d8d36be9786186033e0e0ff94b9654f248b065...e866b16b101d1ff94127c72dff6cd4b93d81d216
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231120/c928b05f/attachment-0001.html>
More information about the ghc-commits
mailing list