22 Jun '25
Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC
Commits:
906d4f40 by Alan Zimmerman at 2025-06-22T21:30:39+01:00
Use PPM as Maybe inside PP
- - - - -
2 changed files:
- compiler/GHC/Parser/PreProcess/Macro.hs
- compiler/GHC/Parser/PreProcess/State.hs
Changes:
=====================================
compiler/GHC/Parser/PreProcess/Macro.hs
=====================================
@@ -35,97 +35,90 @@ details
import Data.List (intercalate)
import Data.Map qualified as Map
import Data.Maybe
-
import Data.Semigroup qualified as S
-import GHC.Driver.Errors.Types (PsMessage)
-import GHC.Parser.Lexer qualified as Lexer
+
+import GHC.Base
+import GHC.Parser.Lexer (P (..), PState (..), ParseResult (..))
import GHC.Parser.PreProcess.Eval
import GHC.Parser.PreProcess.ParsePP
import GHC.Parser.PreProcess.Parser qualified as Parser
import GHC.Parser.PreProcess.ParserM
import GHC.Parser.PreProcess.State
import GHC.Prelude
-import GHC.Types.Error (MsgEnvelope)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic (panic)
-- ---------------------------------------------------------------------
--- We evaluate to an Int, which we convert to a bool
+-- We evaluate to an Int, which we convert to a bool
cppCond :: SrcSpan -> String -> PP Bool
cppCond loc str = do
- s <- getPpState
+ r <- runPM $ cppCond' loc str
+ return $ fromMaybe False r
+
+cppCond' :: SrcSpan -> String -> PPM Bool
+cppCond' loc str = do
+ s <- liftPM getPpState
expanded <- expand loc (pp_defines s) str
- case expanded of
+ v <- case Parser.parseExpr expanded of
Left err -> do
- Lexer.addError err
- return False
- Right expanded -> do
- v <- case Parser.parseExpr expanded of
- Left err -> do
- let detail =
- if str == expanded || expanded == ""
- then
- [ text str
- ]
- else
- [ text expanded
- , text "expanded from:"
- , text str
- ]
- addGhcCPPError'
- loc
- "Error evaluating CPP condition:"
- ( text err
- <+> text "of"
- $+$ vcat detail
- )
- return 0
- Right tree -> return (eval tree)
- return (toBool v)
+ let detail =
+ if str == expanded || expanded == ""
+ then
+ [text str]
+ else
+ [ text expanded
+ , text "expanded from:"
+ , text str
+ ]
+ liftPM $
+ addGhcCPPError'
+ loc
+ "Error evaluating CPP condition:"
+ ( text err
+ <+> text "of"
+ $+$ vcat detail
+ )
+ return 0
+ Right tree -> return (eval tree)
+ return (toBool v)
-- ---------------------------------------------------------------------
-expand :: SrcSpan -> MacroDefines -> String -> PP (Either (MsgEnvelope PsMessage) String)
+expand :: SrcSpan -> MacroDefines -> String -> PPM String
expand loc s str = do
case cppLex False str of
Left err -> do
- return
- ( Left $
- mkGhcCPPError'
- loc
- "Error evaluating CPP condition:"
- (text err <+> text "of" $+$ text str)
- )
+ liftPM $
+ addGhcCPPError'
+ loc
+ "Error evaluating CPP condition:"
+ (text err <+> text "of" $+$ text str)
+ failPM
Right tks -> do
- expandedToks <- expandToks loc maxExpansions s tks
- case expandedToks of
- Left err -> return (Left err)
- Right toks -> return $ Right $ combineToks $ map t_str toks
+ toks <- expandToks loc maxExpansions s tks
+ return $ combineToks $ map t_str toks
maxExpansions :: Int
maxExpansions = 15
-expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) [Token])
+expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PPM [Token]
expandToks loc 0 _ ts = do
- return $
- Left $
- mkGhcCPPError'
- loc
- "CPP macro expansion limit hit:"
- (text (combineToks $ map t_str ts))
+ liftPM $
+ addGhcCPPError'
+ loc
+ "CPP macro expansion limit hit:"
+ (text (combineToks $ map t_str ts))
+ failPM
expandToks loc cnt s ts = do
- expansion <- doExpandToks loc False s ts
- case expansion of
- Left err -> return (Left err)
- Right (!expansionDone, !r) ->
- if expansionDone
- then expandToks loc (cnt - 1) s r
- else return (Right r)
-
-doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) (Bool, [Token]))
-doExpandToks _loc ed _ [] = return $ Right (ed, [])
+ (!expansionDone, !r) <- doExpandToks loc False s ts
+ if expansionDone
+ then expandToks loc (cnt - 1) s r
+ else return r
+
+doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PPM (Bool, [Token])
+doExpandToks _loc ed _ [] = return (ed, [])
doExpandToks loc ed s (TIdentifierLParen n : ts) =
-- TIdentifierLParen has no meaning here (only in a #define), so
-- restore it to its constituent tokens
@@ -136,26 +129,26 @@ doExpandToks loc _ s (TIdentifier "defined" : ts) = do
case expandedArgs of
(Just [[TIdentifier macro_name]], rest0) ->
case Map.lookup macro_name s of
- Nothing -> return $ Right (True, TInteger "0" : rest0)
- Just _ -> return $ Right (True, TInteger "1" : rest0)
+ Nothing -> return (True, TInteger "0" : rest0)
+ Just _ -> return (True, TInteger "1" : rest0)
(Nothing, TIdentifier macro_name : ts0) ->
case Map.lookup macro_name s of
- Nothing -> return $ Right (True, TInteger "0" : ts0)
- Just _ -> return $ Right (True, TInteger "1" : ts0)
+ Nothing -> return (True, TInteger "0" : ts0)
+ Just _ -> return (True, TInteger "1" : ts0)
(Nothing, _) -> do
- return $
- Left $
- mkGhcCPPError'
- loc
- "CPP defined: expected an identifier, got:"
- (text (concatMap t_str ts))
+ liftPM $
+ addGhcCPPError'
+ loc
+ "CPP defined: expected an identifier, got:"
+ (text (concatMap t_str ts))
+ failPM -- TODO:AZ make part of addGhcCPPError'?
(Just args, _) -> do
- return $
- Left $
- mkGhcCPPError'
- loc
- "CPP defined: expected a single arg, got:"
- (text (intercalate "," (map (concatMap t_str) args)))
+ liftPM $
+ addGhcCPPError'
+ loc
+ "CPP defined: expected a single arg, got:"
+ (text (intercalate "," (map (concatMap t_str) args)))
+ failPM -- TODO:AZ make part of addGhcCPPError'?
doExpandToks loc ed s (TIdentifier n : ts) = do
(args, rest0) <- getExpandArgs loc ts
let
@@ -168,15 +161,11 @@ doExpandToks loc ed s (TIdentifier n : ts) = do
(ed0, r, rest1) = case m_args of
Nothing -> (True, rhs, ts)
Just _ -> (True, replace_args args m_args rhs, rest0)
- expansion <- doExpandToks loc ed' s ts'
- case expansion of
- Left err -> return $ Left err
- Right (ed'', rest) -> return $ Right (ed'', expanded ++ rest)
+ (ed'', rest) <- doExpandToks loc ed' s ts'
+ return (ed'', expanded ++ rest)
doExpandToks loc ed s (t : ts) = do
- expansion <- doExpandToks loc ed s ts
- case expansion of
- Left err -> return (Left err)
- Right (ed', r) -> return $ Right (ed', t : r)
+ (ed', r) <- doExpandToks loc ed s ts
+ return (ed', t : r)
{-
Note: ['defined' unary operator]
@@ -248,14 +237,15 @@ inner parentheses do not separate arguments.
{- | Look for possible arguments to a macro expansion.
The only thing we look for are commas, open parens, and close parens.
-}
-getExpandArgs :: SrcSpan -> [Token] -> PP (Maybe [[Token]], [Token])
+getExpandArgs :: SrcSpan -> [Token] -> PPM (Maybe [[Token]], [Token])
getExpandArgs loc ts =
case pArgs ts of
Left err -> do
- addGhcCPPError'
- loc
- "CPP: cannot expand macro arguments:"
- (text err <+> text "in" $+$ text (concatMap t_str ts))
+ liftPM $
+ addGhcCPPError'
+ loc
+ "CPP: cannot expand macro arguments:"
+ (text err <+> text "in" $+$ text (concatMap t_str ts))
return (Nothing, ts)
Right r -> return r
@@ -338,6 +328,44 @@ isOther _ = True
-- ---------------------------------------------------------------------
+type PPM = PM PpState
+
+-- | The parsing monad, isomorphic to @StateT PState Maybe@.
+newtype PM p a = PM {unPM :: PState p -> ParseResult p (Maybe a)}
+
+instance Functor (PM p) where
+ fmap = liftM
+
+instance Applicative (PM p) where
+ pure = returnP
+ (<*>) = ap
+
+instance Monad (PM p) where
+ (>>=) = thenP
+
+returnP :: a -> PM p a
+returnP a = a `seq` (PM $ \s -> POk s (Just a))
+
+failPM :: PM p a
+failPM = PM $ \s -> POk s Nothing
+
+thenP :: PM p a -> (a -> PM p b) -> PM p b
+(PM m) `thenP` k = PM $ \s ->
+ case m s of
+ POk s1 Nothing -> POk s1 Nothing
+ POk s1 (Just a) -> (unPM (k a)) s1
+ PFailed s1 -> PFailed s1
+
+runPM :: PM p a -> P p (Maybe a)
+runPM m = P $ \s -> (unPM m) s
+
+liftPM :: P p a -> PM p a
+liftPM m = PM $ \s -> case (unP m) s of
+ POk s1 a -> POk s1 (Just a)
+ PFailed s1 -> PFailed s1
+
+-- ---------------------------------------------------------------------
+
m1 :: Either String [Token]
m1 = cppLex False "`"
=====================================
compiler/GHC/Parser/PreProcess/State.hs
=====================================
@@ -32,10 +32,7 @@ module GHC.Parser.PreProcess.State (
ghcCppEnabled,
setInLinePragma,
getInLinePragma,
- mkGhcCPPError',
addGhcCPPError',
- mkGhcCPPError,
- addGhcCPPError,
) where
import Data.List.NonEmpty ((<|))
@@ -59,6 +56,8 @@ import GHC.Utils.Outputable (hang, text, (<+>))
type PP = P PpState
+-- ---------------------------------------------------------------------
+
data CppState
= CppIgnoring
| CppNormal
@@ -268,7 +267,7 @@ parentScope =
c :| [] -> c -- Perhaps should return enabled instead
_ :| (h : _t) -> h
in
- POk s new_scope
+ POk s (new_scope)
-- Get the current scope value
getScope :: PP PpScope
@@ -427,11 +426,11 @@ mkGhcCPPError' loc title detail =
detail
)
-addGhcCPPError' :: SrcSpan -> String -> SDoc -> P p ()
+addGhcCPPError' :: SrcSpan -> String -> SDoc -> PP ()
addGhcCPPError' loc title detail = Lexer.addError $ mkGhcCPPError' loc title detail
mkGhcCPPError :: SrcSpan -> SDoc -> MsgEnvelope PsMessage
mkGhcCPPError loc err = mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp err
-addGhcCPPError :: SrcSpan -> SDoc -> P p ()
+addGhcCPPError :: SrcSpan -> SDoc -> PP ()
addGhcCPPError loc err = Lexer.addError $ mkGhcCPPError loc err
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/906d4f40f99fb4b2833a303bc06ff7c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/906d4f40f99fb4b2833a303bc06ff7c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] linters: lint-whitespace: bump upper-bound for containers
by Marge Bot (＠marge-bot) 22 Jun '25
by Marge Bot (＠marge-bot) 22 Jun '25
22 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
fbf23539 by Teo Camarasu at 2025-06-22T13:03:25-04:00
linters: lint-whitespace: bump upper-bound for containers
The version of containers was bumped in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13989
- - - - -
1 changed file:
- linters/lint-whitespace/lint-whitespace.cabal
Changes:
=====================================
linters/lint-whitespace/lint-whitespace.cabal
=====================================
@@ -24,7 +24,7 @@ executable lint-whitespace
process
^>= 1.6,
containers
- >= 0.6 && <0.8,
+ >= 0.6 && <0.9,
base
>= 4.14 && < 5,
text
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbf235390bde1df50270fb9b8aaf13a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbf235390bde1df50270fb9b8aaf13a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/supersven/riscv-vectors] 4 commits: Give up with vectors passed by reference
by Sven Tennie (＠supersven) 22 Jun '25
by Sven Tennie (＠supersven) 22 Jun '25
22 Jun '25
Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC
Commits:
eef2ec66 by Sven Tennie at 2025-06-22T13:41:41+02:00
Give up with vectors passed by reference
- - - - -
3e510f90 by Sven Tennie at 2025-06-22T16:11:22+02:00
Adjust test
- - - - -
6c85b16d by Sven Tennie at 2025-06-22T16:11:40+02:00
Fix warnings
- - - - -
7f5ae460 by Sven Tennie at 2025-06-22T17:35:12+02:00
Use OrdList to insert vector configs
- - - - -
6 changed files:
- compiler/GHC/CmmToAsm/RV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RV64/Instr.hs
- compiler/GHC/CmmToAsm/RV64/Ppr.hs
- testsuite/tests/simd/should_run/VectorCCallConv.hs
- + testsuite/tests/simd/should_run/VectorCCallConv.stdout
- testsuite/tests/simd/should_run/VectorCCallConv_c.c
Changes:
=====================================
compiler/GHC/CmmToAsm/RV64/CodeGen.hs
=====================================
@@ -1934,6 +1934,27 @@ genCondBranch true false expr =
-- -----------------------------------------------------------------------------
-- Generating C calls
+-- Note [RISC-V vector C calling convention]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- In short:
+-- 1. The first 16 vector arguments are passed in registers v8 - v23
+-- 2. If there are free general registers, the pointers (references) to more
+-- vectors are passed in them
+-- 3. Otherwise, the pointers are passed on stack
+--
+-- (1) is easy to accomplish. (2) and (3) require the vector register to be
+-- stored with its full width. This width is unknown at compile time. So, the
+-- natural way of storing it as temporary variable on the C stack conflicts
+-- with GHC wanting to know the exact stack size at compile time.
+--
+-- One could consider to allocate space for the vector registers to be passed
+-- by reference on the heap. However, this turned out to be very complex and is
+-- left for later versions of this NCG.
+--
+-- For now, we expect that 16 vector arguments is probably sufficient for very
+-- most function types.
+
-- | Generate a call to a C function.
--
-- - Integer values are passed in GP registers a0-a7.
@@ -2033,27 +2054,6 @@ genCCall target@(ForeignTarget expr _cconv) dest_regs arg_regs = do
`appOL` moveStackUp stackSpaceWords
return code
where
- -- TODO: Deallocate heap-allocated vectors after the main call
- allocVectorHeap :: (Reg, Format, ForeignHint, InstrBlock) -> NatM (Reg, Format, ForeignHint, InstrBlock)
- allocVectorHeap arg@(r, format, hint, code_r) | isVecFormat format = do
- platform <- getPlatform
- resRegUnq <- getUniqueM
- let resLocalReg = LocalReg resRegUnq b64
- resReg = getRegisterReg platform (CmmLocal resLocalReg)
- callCode <- mkCCall "malloc_vlen_vector" [resLocalReg] []
- let code = callCode `appOL` code_r `appOL` toOL [VS1R (OpReg format r) (OpAddr (AddrReg resReg))]
- pure (resReg, II64, hint, code)
- allocVectorHeap _ = panic "Unsupported general case"
-
- mkCCall :: FastString -> [CmmFormal] -> [CmmActual] -> NatM InstrBlock
- mkCCall name dest_regs arg_regs = do
- config <- getConfig
- target <-
- cmmMakeDynamicReference config CallReference
- $ mkForeignLabel name ForeignLabelInThisPackage IsFunction
- let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
- genCCall (ForeignTarget target cconv) dest_regs arg_regs
-
-- Implementation of the RISCV ABI calling convention.
-- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c…
passArguments :: [Reg] -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
@@ -2135,23 +2135,11 @@ genCCall target@(ForeignTarget expr _cconv) dest_regs arg_regs = do
`snocOL` ann (text "Pass vector argument: " <> ppr r) mov
passArguments gpRegs fpRegs vRegs args stackSpaceWords (vReg : accumRegs) accumCode'
- -- No more vector but free gp regs, and we want to pass a vector argument: Pass vector on heap and move its address to gp vector.
- passArguments (gpReg : gpRegs) fpRegs [] (arg@(r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode
- | isVecFormat format = do
- (r', format', _hint, code_r') <- allocVectorHeap arg
- let code = code_r' `appOL` toOL [MOV (OpReg II64 gpReg) (OpReg II64 r')]
- passArguments gpRegs fpRegs [] args stackSpaceWords (gpReg : accumRegs) (accumCode `appOL` code)
-
- -- No more vector and gp regs, and we want to pass a vector argument: Pass vector address on stack and the vector itself on heap.
- -- We need to put its address in the next slot
- -- In RISC-V terms we pass an "aggregate by reference"
- passArguments [] fpRegs [] (arg@(r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode
- | isVecFormat format = do
- (r', format', _hint, code_r') <- allocVectorHeap arg
- let spOffet = 8 * stackSpaceWords
- str = STR format' (OpReg II64 r') (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))
- code = code_r' `snocOL` str
- passArguments [] fpRegs [] args (stackSpaceWords + 1) accumRegs (accumCode `appOL` code)
+ -- No more free vector argument registers , and we want to pass a vector argument.
+ -- See Note [RISC-V vector C calling convention]
+ passArguments _gpRegs _fpRegs [] ((_r, format, _hint, _code_r) : _args) _stackSpaceWords _accumRegs _accumCode
+ | isVecFormat format =
+ panic "C call: no free vector argument registers. We only support 16 vector arguments (registers v8 - v23)."
passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
@@ -2704,7 +2692,6 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks =
VFMIN {} -> 2
VFMAX {} -> 2
VRGATHER {} -> 2
- VS1R {} -> 1
VFMA {} -> 3
-- estimate the subsituted size for jumps to lables
-- jumps to registers have size 1
=====================================
compiler/GHC/CmmToAsm/RV64/Instr.hs
=====================================
@@ -132,7 +132,6 @@ regUsageOfInstr platform instr = case instr of
-- allocator doesn't use the src* registers as dst. (Otherwise, we end up
-- with an illegal instruction.)
VRGATHER dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst ++ regOp src1 ++ regOp src2)
- VS1R src dst -> usage (regOp src ++ regOp dst, [])
FMA _ dst src1 src2 src3 ->
usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)
VFMA _ op1 op2 op3 ->
@@ -249,7 +248,6 @@ patchRegsOfInstr instr env = case instr of
VFMIN o1 o2 o3 -> VFMIN (patchOp o1) (patchOp o2) (patchOp o3)
VFMAX o1 o2 o3 -> VFMAX (patchOp o1) (patchOp o2) (patchOp o3)
VRGATHER o1 o2 o3 -> VRGATHER (patchOp o1) (patchOp o2) (patchOp o3)
- VS1R o1 o2 -> VS1R (patchOp o1) (patchOp o2)
FMA s o1 o2 o3 o4 ->
FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
VFMA s o1 o2 o3 ->
@@ -701,7 +699,6 @@ data Instr
| VFMAX Operand Operand Operand
| VFMA FMASign Operand Operand Operand
| VRGATHER Operand Operand Operand
- | VS1R Operand Operand
data Signage = Signed | Unsigned
deriving (Eq, Show)
@@ -793,7 +790,6 @@ instrCon i =
VFMIN {} -> "VFMIN"
VFMAX {} -> "VFMAX"
VRGATHER {} -> "VRGATHER"
- VS1R {} -> "VS1R"
FMA variant _ _ _ _ ->
case variant of
FMAdd -> "FMADD"
=====================================
compiler/GHC/CmmToAsm/RV64/Ppr.hs
=====================================
@@ -22,6 +22,7 @@ import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment)
import GHC.Types.Unique (getUnique, pprUniqueAlways)
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Data.OrdList
pprNatCmmDecl :: forall doc. (IsDoc doc) => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
pprNatCmmDecl config (CmmData section dats) =
@@ -143,7 +144,7 @@ pprBasicBlock ::
pprBasicBlock config info_env (BasicBlock blockid instrs) =
maybe_infotable
$ pprLabel platform asmLbl
- $$ vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} instrs'))
+ $$ (vcat . fromOL) (mapOL (pprInstr platform) (id {-detectTrivialDeadlock-} instrs'))
$$ ppWhen
(ncgDwarfEnabled config)
( -- Emit both end labels since this may end up being a standalone
@@ -154,7 +155,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) =
)
)
where
- instrs' = injectVectorConfig optInstrs
+ instrs' = injectVectorConfig (toOL optInstrs)
-- TODO: Check if we can filter more instructions here.
-- TODO: Shouldn't this be a more general check on a higher level? And, is this still needed?
-- Filter out identity moves. E.g. mov x18, x18 will be dropped.
@@ -163,34 +164,34 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) =
f (MOV o1 o2) | o1 == o2 = False
f _ = True
- injectVectorConfig :: [Instr] -> [Instr]
- injectVectorConfig instrs = fst $ foldl injectVectorConfig' ([], Nothing) instrs
+ injectVectorConfig :: OrdList Instr -> OrdList Instr
+ injectVectorConfig instrs = fst $ foldlOL injectVectorConfig' (nilOL, Nothing) instrs
-- TODO: Fuse this with optInstrs
-- TODO: Check config and only run this when vectors are configured
-- TODO: Check if vectorMinBits is sufficient for the vector config
- injectVectorConfig' :: ([Instr], Maybe Format) -> Instr -> ([Instr], Maybe Format)
+ injectVectorConfig' :: (OrdList Instr, Maybe Format) -> Instr -> (OrdList Instr, Maybe Format)
injectVectorConfig' (accInstr, configuredVecFmt) currInstr =
let configuredVecFmt' Nothing = Nothing
configuredVecFmt' (Just fmt') = if isJumpishInstr currInstr then Nothing else Just fmt'
in case (configuredVecFmt, instrVecFormat platform currInstr) of
- (fmtA, Nothing) ->
+ (_fmtA, Nothing) ->
-- no vector instruction
( accInstr
- -- TODO: The performance of this appending is probably horrible. Check OrdList.
- ++ [ -- (MULTILINE_COMMENT (text "No vector instruction" <> colon <+> text (instrCon currInstr) <+> pprInstr platform currInstr <> dot <> text "Current context" <> colon <+> ppr fmtA <> comma <+> text "New context" <+> ppr (configuredVecFmt' configuredVecFmt))),
- currInstr
- ],
+ `appOL` toOL
+ [ -- (MULTILINE_COMMENT (text "No vector instruction" <> colon <+> text (instrCon currInstr) <+> pprInstr platform currInstr)),
+ currInstr
+ ],
configuredVecFmt' configuredVecFmt
)
(Nothing, Just fmtB) ->
-- vector instruction, but no active config
( accInstr
- -- TODO: The performance of this appending is probably horrible. Check OrdList.
- ++ [ COMMENT (text "No active vector config. Setting" <+> ppr fmtB),
- (configVec fmtB),
- currInstr
- ],
+ `appOL` toOL
+ [ COMMENT (text "No active vector config. Setting" <+> ppr fmtB),
+ (configVec fmtB),
+ currInstr
+ ],
configuredVecFmt' (Just fmtB)
)
(Just fmtA, Just fmtB) ->
@@ -198,15 +199,20 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) =
then
-- vectors already correctly configured
( accInstr
- -- TODO: The performance of this appending is probably horrible. Check OrdList.
- ++ [COMMENT (text "Active vector config. Keeping" <+> ppr fmtB), currInstr],
+ `appOL` toOL
+ [ COMMENT (text "Active vector config. Keeping" <+> ppr fmtB),
+ currInstr
+ ],
configuredVecFmt' (Just fmtA)
)
else
-- re-configure
( accInstr
- -- TODO: The performance of this appending is probably horrible. Check OrdList.
- ++ [(COMMENT (text "Wrong active vector config. Setting" <+> ppr fmtB)), (configVec fmtB), currInstr],
+ `appOL` toOL
+ [ (COMMENT (text "Wrong active vector config. Setting" <+> ppr fmtB)),
+ (configVec fmtB),
+ currInstr
+ ],
configuredVecFmt' (Just fmtB)
)
@@ -876,8 +882,6 @@ pprInstr platform instr = case instr of
VFMAX o1 o2 o3 -> pprPanic "RV64.pprInstr - VFMAX wrong operands." (pprOps platform [o1, o2, o3])
VRGATHER o1 o2 o3 | allVectorRegOps [o1, o2, o3] -> op3 (text "\tvrgather.vv") o1 o2 o3
VRGATHER o1 o2 o3 -> pprPanic "RV64.pprInstr - VRGATHER wrong operands." (pprOps platform [o1, o2, o3])
- VS1R o1 o2 | isVectorRegOp o1 -> op2 (text "\tvs1r.v") o1 o2
- VS1R o1 o2 -> pprPanic "RV64.pprInstr - VS1R wrong operands." (pprOps platform [o1, o2])
instr -> panic $ "RV64.pprInstr - Unknown instruction: " ++ instrCon instr
where
op1 op o1 = line $ op <+> pprOp platform o1
=====================================
testsuite/tests/simd/should_run/VectorCCallConv.hs
=====================================
@@ -9,16 +9,10 @@ module Main where
import Data.Int
import GHC.Int
import GHC.Prim
+import System.IO
foreign import ccall "printVecs_int64x2_c"
printVecs_int64x2# ::
- Int64X2# -> -- v1
- Int64X2# -> -- v2
- Int64X2# -> -- v3
- Int64X2# -> -- v4
- Int64X2# -> -- v5
- Int64X2# -> -- v6
- Int64X2# -> -- v7
Int64X2# -> -- v8
Int64X2# -> -- v9
Int64X2# -> -- v10
@@ -35,75 +29,38 @@ foreign import ccall "printVecs_int64x2_c"
Int64X2# -> -- v21
Int64X2# -> -- v22
Int64X2# -> -- v23
- Int64X2# -> -- v24
- Int64X2# -> -- v25
- -- Int64X2# -> -- v26
- -- Int64X2# -> -- v27
- -- Int64X2# -> -- v28
- -- Int64X2# -> -- v29
- -- Int64X2# -> -- v30
- -- Int64X2# ->
- -- Int64X2# ->
- -- Int64X2# ->
- -- Int64X2# ->
- -- Int64X2# ->
- -- Int64X2# ->
IO ()
--- foreign import ccall "return_int64X2"
--- return_int64X2# :: (# #) -> Int64X2#
---
--- unpackInt64X2 :: Int64X2# -> (Int64, Int64)
--- unpackInt64X2 v = case unpackInt64X2# v of
--- (# x0, x1 #) -> (I64# x0, I64# x1)
+foreign import ccall "return_int64X2"
+ return_int64X2# :: (# #) -> Int64X2#
+
+unpackInt64X2 :: Int64X2# -> (Int64, Int64)
+unpackInt64X2 v = case unpackInt64X2# v of
+ (# x0, x1 #) -> (I64# x0, I64# x1)
main :: IO ()
main = do
- let v1 = packInt64X2# (# 0#Int64, 1#Int64 #)
- v2 = packInt64X2# (# 2#Int64, 3#Int64 #)
- v3 = packInt64X2# (# 4#Int64, 5#Int64 #)
- v4 = packInt64X2# (# 6#Int64, 7#Int64 #)
- v5 = packInt64X2# (# 8#Int64, 9#Int64 #)
- v6 = packInt64X2# (# 10#Int64, 11#Int64 #)
- v7 = packInt64X2# (# 12#Int64, 13#Int64 #)
- v8 = packInt64X2# (# 14#Int64, 15#Int64 #)
- v9 = packInt64X2# (# 16#Int64, 17#Int64 #)
- v10 = packInt64X2# (# 18#Int64, 19#Int64 #)
- v11 = packInt64X2# (# 20#Int64, 21#Int64 #)
- v12 = packInt64X2# (# 22#Int64, 23#Int64 #)
- v13 = packInt64X2# (# 24#Int64, 25#Int64 #)
- v14 = packInt64X2# (# 26#Int64, 27#Int64 #)
- v15 = packInt64X2# (# 28#Int64, 29#Int64 #)
- v16 = packInt64X2# (# 30#Int64, 31#Int64 #)
- v17 = packInt64X2# (# 32#Int64, 33#Int64 #)
- v18 = packInt64X2# (# 34#Int64, 35#Int64 #)
- v19 = packInt64X2# (# 36#Int64, 37#Int64 #)
- v20 = packInt64X2# (# 38#Int64, 39#Int64 #)
- v21 = packInt64X2# (# 40#Int64, 41#Int64 #)
- v22 = packInt64X2# (# 42#Int64, 43#Int64 #)
- v23 = packInt64X2# (# 44#Int64, 45#Int64 #)
- v24 = packInt64X2# (# 46#Int64, 47#Int64 #)
- v25 = packInt64X2# (# 48#Int64, 49#Int64 #)
- v26 = packInt64X2# (# 50#Int64, 51#Int64 #)
- v27 = packInt64X2# (# 52#Int64, 53#Int64 #)
- v28 = packInt64X2# (# 54#Int64, 55#Int64 #)
- v29 = packInt64X2# (# 56#Int64, 57#Int64 #)
- v30 = packInt64X2# (# 58#Int64, 59#Int64 #)
- -- v31 = packInt64X2# (# 60#Int64, 61#Int64 #)
- -- v32 = packInt64X2# (# 62#Int64, 63#Int64 #)
- -- v33 = packInt64X2# (# 64#Int64, 65#Int64 #)
- -- v34 = packInt64X2# (# 66#Int64, 67#Int64 #)
- -- v35 = packInt64X2# (# 68#Int64, 69#Int64 #)
- -- v36 = packInt64X2# (# 70#Int64, 71#Int64 #)
+ -- Use some negative values to fill more bits and discover possible overlaps.
+ let v8 = packInt64X2# (# 0#Int64, -1#Int64 #)
+ v9 = packInt64X2# (# -2#Int64, 3#Int64 #)
+ v10 = packInt64X2# (# -4#Int64, 5#Int64 #)
+ v11 = packInt64X2# (# -6#Int64, 7#Int64 #)
+ v12 = packInt64X2# (# -8#Int64, 9#Int64 #)
+ v13 = packInt64X2# (# -10#Int64, 11#Int64 #)
+ v14 = packInt64X2# (# -12#Int64, 13#Int64 #)
+ v15 = packInt64X2# (# -14#Int64, 15#Int64 #)
+ v16 = packInt64X2# (# -16#Int64, 17#Int64 #)
+ v17 = packInt64X2# (# -18#Int64, 19#Int64 #)
+ v18 = packInt64X2# (# -20#Int64, 21#Int64 #)
+ v19 = packInt64X2# (# -22#Int64, 23#Int64 #)
+ v20 = packInt64X2# (# -24#Int64, 25#Int64 #)
+ v21 = packInt64X2# (# -26#Int64, 27#Int64 #)
+ v22 = packInt64X2# (# -28#Int64, 29#Int64 #)
+ v23 = packInt64X2# (# -30#Int64, 31#Int64 #)
+ print "Arguments"
+ hFlush stdout
printVecs_int64x2#
- v1
- v2
- v3
- v4
- v5
- v6
- v7
v8
v9
v10
@@ -120,22 +77,7 @@ main = do
v21
v22
v23
- v24
- v25
-
--- v26
-
--- v27
--- v28
--- v29
--- v30
-
--- v31
--- v32
--- v33
--- v34
--- v35
--- v26
--- let v = return_int64X2#
--- print $ unpackInt64X2 v
+ print "Return values"
+ let v = return_int64X2# (# #)
+ print $ unpackInt64X2 v
=====================================
testsuite/tests/simd/should_run/VectorCCallConv.stdout
=====================================
@@ -0,0 +1,19 @@
+"Arguments"
+[0, -1]
+[-2, 3]
+[-4, 5]
+[-6, 7]
+[-8, 9]
+[-10, 11]
+[-12, 13]
+[-14, 15]
+[-16, 17]
+[-18, 19]
+[-20, 21]
+[-22, 23]
+[-24, 25]
+[-26, 27]
+[-28, 29]
+[-30, 31]
+"Return values"
+(-9223372036854775808,9223372036854775807)
=====================================
testsuite/tests/simd/should_run/VectorCCallConv_c.c
=====================================
@@ -19,10 +19,7 @@ void printVecs_int64x2_c(vint64m1_t v8, vint64m1_t v9, vint64m1_t v10,
vint64m1_t v14, vint64m1_t v15, vint64m1_t v16,
vint64m1_t v17, vint64m1_t v18, vint64m1_t v19,
vint64m1_t v20, vint64m1_t v21, vint64m1_t v22,
- vint64m1_t v23, vint64m1_t a0, vint64m1_t a1,
- vint64m1_t a2, vint64m1_t a3, vint64m1_t a4,
- vint64m1_t a5, vint64m1_t a6, vint64m1_t a7,
- vint64m1_t s0) {
+ vint64m1_t v23) {
printVec_int64(v8, 2);
printVec_int64(v9, 2);
printVec_int64(v10, 2);
@@ -39,31 +36,11 @@ void printVecs_int64x2_c(vint64m1_t v8, vint64m1_t v9, vint64m1_t v10,
printVec_int64(v21, 2);
printVec_int64(v22, 2);
printVec_int64(v23, 2);
- printVec_int64(a0, 2);
- printVec_int64(a1, 2);
- printVec_int64(a2, 2);
- printVec_int64(a3, 2);
- printVec_int64(a4, 2);
- printVec_int64(a5, 2);
- printVec_int64(a6, 2);
- printVec_int64(a7, 2);
- printVec_int64(s0, 2);
- // printVec_int64(v26, 2);
- // printVec_int64(v27, 2);
- // printVec_int64(v28, 2);
- // printVec_int64(v29, 2);
- // printVec_int64(v30, 2);
- // printVec_int64(v31, 2);
- // printVec_int64(v32, 2);
- // printVec_int64(v33, 2);
- // printVec_int64(v34, 2);
- // printVec_int64(v35, 2);
- // printVec_int64(v36, 2);
- //
+
fflush(stdout);
}
-// vint64m1_t return_int64X2() {
-// int64_t v[] = {INT64_MIN, INT64_MAX};
-// return __riscv_vle64_v_i64m1(v, 2);
-// }
+vint64m1_t return_int64X2() {
+ int64_t v[] = {INT64_MIN, INT64_MAX};
+ return __riscv_vle64_v_i64m1(v, 2);
+}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8497fb6f9fd87f0b1f1a61b0d541c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8497fb6f9fd87f0b1f1a61b0d541c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/ghc-cpp] 2 commits: Harvest some commonality
by Alan Zimmerman (＠alanz) 22 Jun '25
by Alan Zimmerman (＠alanz) 22 Jun '25
22 Jun '25
Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC
Commits:
14999739 by Alan Zimmerman at 2025-06-21T17:03:55+01:00
Harvest some commonality
- - - - -
e4491409 by Alan Zimmerman at 2025-06-22T15:14:55+01:00
Use PPM as Maybe inside PP
- - - - -
2 changed files:
- compiler/GHC/Parser/PreProcess/Macro.hs
- compiler/GHC/Parser/PreProcess/State.hs
Changes:
=====================================
compiler/GHC/Parser/PreProcess/Macro.hs
=====================================
@@ -37,104 +37,86 @@ import Data.Map qualified as Map
import Data.Maybe
import Data.Semigroup qualified as S
-import GHC.Driver.Errors.Types (PsMessage)
-import GHC.Parser.Lexer qualified as Lexer
import GHC.Parser.PreProcess.Eval
import GHC.Parser.PreProcess.ParsePP
import GHC.Parser.PreProcess.Parser qualified as Parser
import GHC.Parser.PreProcess.ParserM
import GHC.Parser.PreProcess.State
import GHC.Prelude
-import GHC.Types.Error (MsgEnvelope)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic (panic)
-- ---------------------------------------------------------------------
--- We evaluate to an Int, which we convert to a bool
+-- We evaluate to an Int, which we convert to a bool
cppCond :: SrcSpan -> String -> PP Bool
cppCond loc str = do
- s <- getPpState
+ r <- runPM $ cppCond' loc str
+ return $ fromMaybe False r
+
+cppCond' :: SrcSpan -> String -> PPM Bool
+cppCond' loc str = do
+ s <- liftPM getPpState
expanded <- expand loc (pp_defines s) str
- case expanded of
+ v <- case Parser.parseExpr expanded of
Left err -> do
- Lexer.addError err
- return False
- Right expanded -> do
- v <- case Parser.parseExpr expanded of
- Left err -> do
- let detail =
- if str == expanded || expanded == ""
- then
- [ text str
- ]
- else
- [ text expanded
- , text "expanded from:"
- , text str
- ]
- addGhcCPPError
- loc
- ( hang
- (text "Error evaluating CPP condition:")
- 2
- ( text err
- <+> text "of"
- $+$ vcat detail
- )
- )
- return 0
- Right tree -> return (eval tree)
- return (toBool v)
+ let detail =
+ if str == expanded || expanded == ""
+ then
+ [text str]
+ else
+ [ text expanded
+ , text "expanded from:"
+ , text str
+ ]
+ liftPM $
+ addGhcCPPError'
+ loc
+ "Error evaluating CPP condition:"
+ ( text err
+ <+> text "of"
+ $+$ vcat detail
+ )
+ return 0
+ Right tree -> return (eval tree)
+ return (toBool v)
-- ---------------------------------------------------------------------
-expand :: SrcSpan -> MacroDefines -> String -> PP (Either (MsgEnvelope PsMessage) String)
+expand :: SrcSpan -> MacroDefines -> String -> PPM String
expand loc s str = do
case cppLex False str of
Left err -> do
- return
- ( Left $
- mkGhcCPPError
- loc
- ( hang
- (text "Error evaluating CPP condition:")
- 2
- (text err <+> text "of" $+$ text str)
- )
- )
+ liftPM $
+ addGhcCPPError'
+ loc
+ "Error evaluating CPP condition:"
+ (text err <+> text "of" $+$ text str)
+ failPM
Right tks -> do
- expandedToks <- expandToks loc maxExpansions s tks
- case expandedToks of
- Left err -> return (Left err)
- Right toks -> return $ Right $ combineToks $ map t_str toks
+ toks <- expandToks loc maxExpansions s tks
+ return $ combineToks $ map t_str toks
maxExpansions :: Int
maxExpansions = 15
-expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) [Token])
+expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PPM [Token]
expandToks loc 0 _ ts = do
- return $
- Left $
- mkGhcCPPError
- loc
- ( hang
- (text "CPP macro expansion limit hit:")
- 2
- (text (combineToks $ map t_str ts))
- )
+ liftPM $
+ addGhcCPPError'
+ loc
+ "CPP macro expansion limit hit:"
+ (text (combineToks $ map t_str ts))
+ failPM
expandToks loc cnt s ts = do
- expansion <- doExpandToks loc False s ts
- case expansion of
- Left err -> return (Left err)
- Right (!expansionDone, !r) ->
- if expansionDone
- then expandToks loc (cnt - 1) s r
- else return (Right r)
-
-doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) (Bool, [Token]))
-doExpandToks _loc ed _ [] = return $ Right (ed, [])
+ (!expansionDone, !r) <- doExpandToks loc False s ts
+ if expansionDone
+ then expandToks loc (cnt - 1) s r
+ else return r
+
+doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PPM (Bool, [Token])
+doExpandToks _loc ed _ [] = return (ed, [])
doExpandToks loc ed s (TIdentifierLParen n : ts) =
-- TIdentifierLParen has no meaning here (only in a #define), so
-- restore it to its constituent tokens
@@ -145,32 +127,26 @@ doExpandToks loc _ s (TIdentifier "defined" : ts) = do
case expandedArgs of
(Just [[TIdentifier macro_name]], rest0) ->
case Map.lookup macro_name s of
- Nothing -> return $ Right (True, TInteger "0" : rest0)
- Just _ -> return $ Right (True, TInteger "1" : rest0)
+ Nothing -> return (True, TInteger "0" : rest0)
+ Just _ -> return (True, TInteger "1" : rest0)
(Nothing, TIdentifier macro_name : ts0) ->
case Map.lookup macro_name s of
- Nothing -> return $ Right (True, TInteger "0" : ts0)
- Just _ -> return $ Right (True, TInteger "1" : ts0)
+ Nothing -> return (True, TInteger "0" : ts0)
+ Just _ -> return (True, TInteger "1" : ts0)
(Nothing, _) -> do
- return $
- Left $
- mkGhcCPPError
- loc
- ( hang
- (text "CPP defined: expected an identifier, got:")
- 2
- (text (concatMap t_str ts))
- )
+ liftPM $
+ addGhcCPPError'
+ loc
+ "CPP defined: expected an identifier, got:"
+ (text (concatMap t_str ts))
+ failPM -- TODO:AZ make part of addGhcCPPError'?
(Just args, _) -> do
- return $
- Left $
- mkGhcCPPError
- loc
- ( hang
- (text "CPP defined: expected a single arg, got:")
- 2
- (text (intercalate "," (map (concatMap t_str) args)))
- )
+ liftPM $
+ addGhcCPPError'
+ loc
+ "CPP defined: expected a single arg, got:"
+ (text (intercalate "," (map (concatMap t_str) args)))
+ failPM -- TODO:AZ make part of addGhcCPPError'?
doExpandToks loc ed s (TIdentifier n : ts) = do
(args, rest0) <- getExpandArgs loc ts
let
@@ -183,15 +159,11 @@ doExpandToks loc ed s (TIdentifier n : ts) = do
(ed0, r, rest1) = case m_args of
Nothing -> (True, rhs, ts)
Just _ -> (True, replace_args args m_args rhs, rest0)
- expansion <- doExpandToks loc ed' s ts'
- case expansion of
- Left err -> return $ Left err
- Right (ed'', rest) -> return $ Right (ed'', expanded ++ rest)
+ (ed'', rest) <- doExpandToks loc ed' s ts'
+ return (ed'', expanded ++ rest)
doExpandToks loc ed s (t : ts) = do
- expansion <- doExpandToks loc ed s ts
- case expansion of
- Left err -> return (Left err)
- Right (ed', r) -> return $ Right (ed', t : r)
+ (ed', r) <- doExpandToks loc ed s ts
+ return (ed', t : r)
{-
Note: ['defined' unary operator]
@@ -263,17 +235,15 @@ inner parentheses do not separate arguments.
{- | Look for possible arguments to a macro expansion.
The only thing we look for are commas, open parens, and close parens.
-}
-getExpandArgs :: SrcSpan -> [Token] -> PP (Maybe [[Token]], [Token])
+getExpandArgs :: SrcSpan -> [Token] -> PPM (Maybe [[Token]], [Token])
getExpandArgs loc ts =
case pArgs ts of
Left err -> do
- addGhcCPPError
- loc
- ( hang
- (text "CPP: cannot expand macro arguments:")
- 2
+ liftPM $
+ addGhcCPPError'
+ loc
+ "CPP: cannot expand macro arguments:"
(text err <+> text "in" $+$ text (concatMap t_str ts))
- )
return (Nothing, ts)
Right r -> return r
=====================================
compiler/GHC/Parser/PreProcess/State.hs
=====================================
@@ -8,6 +8,7 @@ module GHC.Parser.PreProcess.State (
PpState (..),
initPpState,
PP,
+ PPM,
PpScope (..),
PpGroupState (..),
MacroDefines,
@@ -32,8 +33,11 @@ module GHC.Parser.PreProcess.State (
ghcCppEnabled,
setInLinePragma,
getInLinePragma,
- mkGhcCPPError,
- addGhcCPPError,
+ PM (..),
+ runPM,
+ liftPM,
+ failPM,
+ addGhcCPPError',
) where
import Data.List.NonEmpty ((<|))
@@ -51,12 +55,51 @@ import GHC.Types.SrcLoc
import GHC.Utils.Error
import GHC.Prelude
-import GHC.Utils.Outputable (text, (<+>))
+import GHC.Utils.Outputable (hang, text, (<+>))
-- ---------------------------------------------------------------------
+type PPM = PM PpState
type PP = P PpState
+-- ---------------------------------------------------------------------
+
+-- | The parsing monad, isomorphic to @StateT PState Maybe@.
+newtype PM p a = PM {unPM :: PState p -> ParseResult p (Maybe a)}
+
+instance Functor (PM p) where
+ fmap = liftM
+
+instance Applicative (PM p) where
+ pure = returnP
+ (<*>) = ap
+
+instance Monad (PM p) where
+ (>>=) = thenP
+
+returnP :: a -> PM p a
+returnP a = a `seq` (PM $ \s -> POk s (Just a))
+
+failPM :: PM p a
+failPM = PM $ \s -> POk s Nothing
+
+thenP :: PM p a -> (a -> PM p b) -> PM p b
+(PM m) `thenP` k = PM $ \s ->
+ case m s of
+ POk s1 Nothing -> POk s1 Nothing
+ POk s1 (Just a) -> (unPM (k a)) s1
+ PFailed s1 -> PFailed s1
+
+runPM :: PM p a -> P p (Maybe a)
+runPM m = P $ \s -> (unPM m) s
+
+liftPM :: P p a -> PM p a
+liftPM m = PM $ \s -> case (unP m) s of
+ POk s1 a -> POk s1 (Just a)
+ PFailed s1 -> PFailed s1
+
+-- ---------------------------------------------------------------------
+
data CppState
= CppIgnoring
| CppNormal
@@ -238,15 +281,15 @@ acceptingStateChange old new =
-- Exit a scope group
popAccepting :: SrcSpan -> PP AcceptingResult
popAccepting loc = do
- scopes <- getScopes
- new_scope <- case scopes of
- c :| [] -> do
- addGhcCPPError loc (text "#endif without #if")
- return (c :| [])
- _ :| (h : t) -> return (h :| t)
- setScopes new_scope
- let current = scopeValue scopes
- return (acceptingStateChange current (scopeValue new_scope))
+ scopes <- getScopes
+ new_scope <- case scopes of
+ c :| [] -> do
+ addGhcCPPError loc (text "#endif without #if")
+ return (c :| [])
+ _ :| (h : t) -> return (h :| t)
+ setScopes new_scope
+ let current = scopeValue scopes
+ return (acceptingStateChange current (scopeValue new_scope))
scopeValue :: NonEmpty PpScope -> Bool
scopeValue s = pp_accepting $ NonEmpty.head s
@@ -266,7 +309,7 @@ parentScope =
c :| [] -> c -- Perhaps should return enabled instead
_ :| (h : _t) -> h
in
- POk s new_scope
+ POk s (new_scope)
-- Get the current scope value
getScope :: PP PpScope
@@ -415,8 +458,21 @@ insertMacroDef (MacroName name args) def md =
-- ---------------------------------------------------------------------
+mkGhcCPPError' :: SrcSpan -> String -> SDoc -> MsgEnvelope PsMessage
+mkGhcCPPError' loc title detail =
+ mkGhcCPPError
+ loc
+ ( hang
+ (text title)
+ 2
+ detail
+ )
+
+addGhcCPPError' :: SrcSpan -> String -> SDoc -> PP ()
+addGhcCPPError' loc title detail = Lexer.addError $ mkGhcCPPError' loc title detail
+
mkGhcCPPError :: SrcSpan -> SDoc -> MsgEnvelope PsMessage
mkGhcCPPError loc err = mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp err
-addGhcCPPError :: SrcSpan -> SDoc -> P p ()
+addGhcCPPError :: SrcSpan -> SDoc -> PP ()
addGhcCPPError loc err = Lexer.addError $ mkGhcCPPError loc err
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c6739013d4f997f8292a3f7969ec1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c6739013d4f997f8292a3f7969ec1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Visible forall in GADTs (#25127)
by Marge Bot (＠marge-bot) 22 Jun '25
by Marge Bot (＠marge-bot) 22 Jun '25
22 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
fbc0b92a by Vladislav Zavialov at 2025-06-22T04:25:16+03:00
Visible forall in GADTs (#25127)
Add support for visible dependent quantification `forall a -> t` in
types of data constructors, e.g.
data KindVal a where
K :: forall k.
forall (a::k) -> -- now allowed!
k ->
KindVal a
For details, see docs/users_guide/exts/required_type_arguments.rst,
which has gained a new subsection.
DataCon in compiler/GHC/Core/DataCon.hs
---------------------------------------
The main change in this patch is that DataCon, the Core representation
of a data constructor, now uses a different type to store user-written
type variable binders:
- dcUserTyVarBinders :: [InvisTVBinder]
+ dcUserTyVarBinders :: [TyVarBinder]
where
type TyVarBinder = VarBndr TyVar ForAllTyFlag
type InvisTVBinder = VarBndr TyVar Specificity
and
data Specificity = InferredSpec | SpecifiedSpec
data ForAllTyFlag = Invisible Specificity | Required
This change necessitates some boring, mechanical changes scattered
throughout the diff:
... is now used in place of ...
-----------------+---------------
TyVarBinder | InvisTVBinder
IfaceForAllBndr | IfaceForAllSpecBndr
Specified | SpecifiedSpec
Inferred | InferredSpec
mkForAllTys | mkInvisForAllTys
additionally,
tyVarSpecToBinders -- added or removed calls
ifaceForAllSpecToBndrs -- removed calls
Visibility casts in mkDataConRep
--------------------------------
Type abstractions in Core (/\a. e) always have type (forall a. t)
because coreTyLamForAllTyFlag = Specified. This is also true of data
constructor workers. So we may be faced with the following:
data con worker: (forall a. blah)
data con wrapper: (forall a -> blah)
In this case the wrapper must use a visibility cast (e |> ForAllCo ...)
with appropriately set fco_vis{L,R}. Relevant functions:
mkDataConRep in compiler/GHC/Types/Id/Make.hs
dataConUserTyVarBindersNeedWrapper in compiler/GHC/Core/DataCon.hs
mkForAllVisCos in compiler/GHC/Core/Coercion.hs
mkCoreTyLams in compiler/GHC/Core/Make.hs
mkWpForAllCast in compiler/GHC/Tc/Types/Evidence.hs
More specifically:
- dataConUserTyVarBindersNeedWrapper has been updated to answer "yes"
if there are visible foralls in the type of the data constructor.
- mkDataConRep now uses mkCoreTyLams to generate the big lambda
abstractions (/\a b c. e) in the data con wrapper.
- mkCoreTyLams is a variant of mkCoreLams that applies visibility casts
as needed. It similar in purpose to the pre-existing mkWpForAllCast,
so the common bits have been factored out into mkForAllVisCos.
ConDecl in compiler/Language/Haskell/Syntax/Decls.hs
----------------------------------------------------
The surface syntax representation of a data constructor declaration is
ConDecl. In accordance with the proposal, only GADT syntax is extended
with support for visible forall, so we are interested in ConDeclGADT.
ConDeclGADT's field con_bndrs has been renamed to con_outer_bndrs
and is now accompanied by con_inner_bndrs:
con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass)
con_inner_bndrs :: [HsForAllTelescope pass]
Visible foralls always end up in con_inner_bndrs. The outer binders are
stored and processed separately to support implicit quantification and
the forall-or-nothing rule, a design established by HsSigType.
A side effect of this change is that even in absence of visible foralls,
GHC now permits multiple invisible foralls, e.g.
data T a where { MkT :: forall a b. forall c d. ... -> T a }
But of course, this is done in service of making at least some of these
foralls visible. The entire compiler front-end has been updated to deal
with con_inner_bndrs. See the following modified or added functions:
Parser:
mkGadtDecl in compiler/GHC/Parser/PostProcess.hs
splitLHsGadtTy in compiler/GHC/Hs/Type.hs
Pretty-printer:
pprConDecl in compiler/GHC/Hs/Decls.hs
pprHsForAllTelescope in compiler/GHC/Hs/Type.hs
Renamer:
rnConDecl in compiler/GHC/Rename/Module.hs
bindHsForAllTelescopes in compiler/GHC/Rename/HsType.hs
extractHsForAllTelescopes in compiler/GHC/Rename/HsType.hs
Type checker:
tcConDecl in compiler/GHC/Tc/TyCl.hs
tcGadtConTyVarBndrs in compiler/GHC/Tc/Gen/HsType.hs
Template Haskell
----------------
The TH AST is left unchanged for the moment to avoid breakage. An
attempt to quote or reify a data constructor declaration with visible
forall in its type will result an error:
data ThRejectionReason -- in GHC/HsToCore/Errors/Types.hs
= ...
| ThDataConVisibleForall -- new error constructor
However, as noted in the previous section, GHC now permits multiple
invisible foralls, and TH was updated accordingly. Updated code:
repC in compiler/GHC/HsToCore/Quote.hs
reifyDataCon in compiler/GHC/Tc/Gen/Splice.hs
ppr @Con in libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
Pattern matching
----------------
Everything described above concerns data constructor declarations, but
what about their use sites? Now it is trickier to type check a pattern
match fn(Con a b c)=... because we can no longer assume that a,b,c are
all value arguments. Indeed, some or all of them may very well turn out
to be required type arguments.
To that end, see the changes to:
tcDataConPat in compiler/GHC/Tc/Gen/Pat.hs
splitConTyArgs in compiler/GHC/Tc/Gen/Pat.hs
and the new helpers split_con_ty_args, zip_pats_bndrs.
This is also the reason the TcRnTooManyTyArgsInConPattern error
constructor has been removed. The new code emits TcRnArityMismatch
or TcRnIllegalInvisibleTypePattern.
Summary
-------
DataCon, ConDecl, as well as all related functions have been updated to
support required type arguments in data constructors.
Test cases:
HieGadtConSigs GadtConSigs_th_dump1 GadtConSigs_th_pprint1
T25127_data T25127_data_inst T25127_infix
T25127_newtype T25127_fail_th_quote T25127_fail_arity
TyAppPat_Tricky
Co-authored-by: mniip <mniip(a)mniip.com>
- - - - -
7791cb8d by Teo Camarasu at 2025-06-22T09:56:13-04:00
linters: lint-whitespace: bump upper-bound for containers
The version of containers was bumped in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13989
- - - - -
82 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/DataCon.hs-boot
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/PatSyn.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/Var.hs-boot
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/exts/required_type_arguments.rst
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- linters/lint-whitespace/lint-whitespace.cabal
- testsuite/tests/dependent/should_fail/T16326_Fail6.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- + testsuite/tests/hiefile/should_run/HieGadtConSigs.hs
- + testsuite/tests/hiefile/should_run/HieGadtConSigs.stdout
- testsuite/tests/hiefile/should_run/all.T
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/printer/T18791.stderr
- + testsuite/tests/th/GadtConSigs_th_dump1.hs
- + testsuite/tests/th/GadtConSigs_th_dump1.stderr
- + testsuite/tests/th/GadtConSigs_th_pprint1.hs
- + testsuite/tests/th/GadtConSigs_th_pprint1.stderr
- testsuite/tests/th/T20868.stdout
- testsuite/tests/th/all.T
- testsuite/tests/typecheck/should_compile/T23739a.hs
- + testsuite/tests/typecheck/should_compile/TyAppPat_Tricky.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_fail/T20443b.stderr
- testsuite/tests/typecheck/should_fail/TyAppPat_TooMany.stderr
- + testsuite/tests/vdq-rta/should_compile/T25127_data.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_data_inst.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_infix.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_newtype.hs
- testsuite/tests/vdq-rta/should_compile/all.T
- testsuite/tests/vdq-rta/should_fail/T24159_type_syntax_th_fail.script
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.hs
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.stderr
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.hs
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.stderr
- testsuite/tests/vdq-rta/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9562cbd32c5f35132646541ecf9291…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9562cbd32c5f35132646541ecf9291…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/int-index/visible-forall-gadts] 12 commits: Revert "Specialise: Don't float out constraint components."
by Vladislav Zavialov (＠int-index) 22 Jun '25
by Vladislav Zavialov (＠int-index) 22 Jun '25
22 Jun '25
Vladislav Zavialov pushed to branch wip/int-index/visible-forall-gadts at Glasgow Haskell Compiler / GHC
Commits:
c7aa0c10 by Andreas Klebinger at 2025-06-15T05:47:24-04:00
Revert "Specialise: Don't float out constraint components."
This reverts commit c9abb87ccc0c91cd94f42b3e36270158398326ef.
Turns out two benchmarks from #19747 regresses by a factor of 7-8x if
we do not float those out.
- - - - -
fd998679 by Krzysztof Gogolewski at 2025-06-15T05:48:06-04:00
Fix EPT enforcement when mixing unboxed tuples and non-tuples
The code was assuming that an alternative cannot be returning a normal
datacon and an unboxed tuple at the same time. However, as seen in #26107,
this can happen when using a GADT to refine the representation type.
The solution is just to conservatively return TagDunno.
- - - - -
e64b3f16 by ARATA Mizuki at 2025-06-17T10:13:42+09:00
MachRegs.h: Don't define NO_ARG_REGS when a XMM register is defined
On i386, MAX_REAL_VANILLA_REG is 1, but MAX_REAL_XMM_REG is 4.
If we define NO_ARG_REGS on i386, programs that use SIMD vectors may segfault.
Closes #25985
A couple of notes on the BROKEN_TESTS field:
* This fixes the segfault from T25062_V16.
* The failure from T22187_run was fixed in an earlier commit (see #25561),
but BROKEN_TESTS was missed at that time. Now should be a good time to
mark it fixed.
- - - - -
3e7c6b4d by Matthew Pickering at 2025-06-18T15:34:04-04:00
Improve error messages when implicit lifting fails
This patch concerns programs which automatically try to fix level errors
by inserting `Lift`. For example:
```
foo x = [| x |]
~>
foo x = [| $(lift x) |]
```
Before, there were two problems with the message.
1. (#26031), the location of the error was reported as the whole
quotation.
2. (#26035), the message just mentions there is no Lift instance, but
gives no indicate why the user program needed a Lift instance in the
first place.
This problem is especially bad when you disable
`ImplicitStagePersistence`, so you just end up with a confusing "No
instance for" message rather than an error message about levels
This patch fixes both these issues.
Firstly, `PendingRnSplice` differentiates between a user-written splice
and an implicit lift. Then, the Lift instance is precisely requested
with a specific origin in the typechecker. If the instance fails to be
solved, the message is reported using the `TcRnBadlyLevelled`
constructor (like a normal level error).
Fixes #26031, #26035
- - - - -
44b8cee2 by Cheng Shao at 2025-06-18T15:34:46-04:00
testsuite: add T26120 marked as broken
- - - - -
894a04f3 by Cheng Shao at 2025-06-18T15:34:46-04:00
compiler: fix GHC.SysTools.Ar archive member size writing logic
This patch fixes a long-standing bug in `GHC.SysTools.Ar` that emits
the wrong archive member size in each archive header. It should encode
the exact length of the member payload, excluding any padding byte,
otherwise malformed archive that extracts a broken object with an
extra trailing byte could be created.
Apart from the in-tree `T26120` test, I've also created an out-of-tree
testsuite at https://github.com/TerrorJack/ghc-ar-quickcheck that
contains QuickCheck roundtrip tests for `GHC.SysTools.Ar`. With this
fix, simple roundtrip tests and `writeGNUAr`/GNU `ar` roundtrip test
passes. There might be more bugs lurking in here, but this patch is
still a critical bugfix already.
Fixes #26120 #22586.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
f677ab5f by Lauren Yim at 2025-06-18T15:35:37-04:00
fix some typos in the warnings page in the user guide
- - - - -
b968e1c1 by Rodrigo Mesquita at 2025-06-18T15:36:18-04:00
Add a frozen callstack to throwGhcException
Fixes #25956
- - - - -
a5e0c3a3 by fendor at 2025-06-18T15:36:59-04:00
Update using.rst to advertise full mhu support for GHCi
- - - - -
d3e60e97 by Ryan Scott at 2025-06-18T22:29:21-04:00
Deprecate -Wdata-kinds-tc, make DataKinds issues in typechecker become errors
!11314 introduced the `-Wdata-kinds-tc` warning as part of a fix for #22141.
This was a temporary stopgap measure to allow users who were accidentally
relying on code which needed the `DataKinds` extension in order to typecheck
without having to explicitly enable the extension.
Now that some amount of time has passed, this patch deprecates
`-Wdata-kinds-tc` and upgrades any `DataKinds`-related issues in the
typechecker (which were previously warnings) into errors.
- - - - -
fd5b5177 by Ryan Hendrickson at 2025-06-18T22:30:06-04:00
haddock: Add redact-type-synonyms pragma
`{-# OPTIONS_HADDOCK redact-type-synonyms #-}` pragma will hide the RHS
of type synonyms, and display the result kind instead, if the RHS
contains any unexported types.
- - - - -
fbc0b92a by Vladislav Zavialov at 2025-06-22T04:25:16+03:00
Visible forall in GADTs (#25127)
Add support for visible dependent quantification `forall a -> t` in
types of data constructors, e.g.
data KindVal a where
K :: forall k.
forall (a::k) -> -- now allowed!
k ->
KindVal a
For details, see docs/users_guide/exts/required_type_arguments.rst,
which has gained a new subsection.
DataCon in compiler/GHC/Core/DataCon.hs
---------------------------------------
The main change in this patch is that DataCon, the Core representation
of a data constructor, now uses a different type to store user-written
type variable binders:
- dcUserTyVarBinders :: [InvisTVBinder]
+ dcUserTyVarBinders :: [TyVarBinder]
where
type TyVarBinder = VarBndr TyVar ForAllTyFlag
type InvisTVBinder = VarBndr TyVar Specificity
and
data Specificity = InferredSpec | SpecifiedSpec
data ForAllTyFlag = Invisible Specificity | Required
This change necessitates some boring, mechanical changes scattered
throughout the diff:
... is now used in place of ...
-----------------+---------------
TyVarBinder | InvisTVBinder
IfaceForAllBndr | IfaceForAllSpecBndr
Specified | SpecifiedSpec
Inferred | InferredSpec
mkForAllTys | mkInvisForAllTys
additionally,
tyVarSpecToBinders -- added or removed calls
ifaceForAllSpecToBndrs -- removed calls
Visibility casts in mkDataConRep
--------------------------------
Type abstractions in Core (/\a. e) always have type (forall a. t)
because coreTyLamForAllTyFlag = Specified. This is also true of data
constructor workers. So we may be faced with the following:
data con worker: (forall a. blah)
data con wrapper: (forall a -> blah)
In this case the wrapper must use a visibility cast (e |> ForAllCo ...)
with appropriately set fco_vis{L,R}. Relevant functions:
mkDataConRep in compiler/GHC/Types/Id/Make.hs
dataConUserTyVarBindersNeedWrapper in compiler/GHC/Core/DataCon.hs
mkForAllVisCos in compiler/GHC/Core/Coercion.hs
mkCoreTyLams in compiler/GHC/Core/Make.hs
mkWpForAllCast in compiler/GHC/Tc/Types/Evidence.hs
More specifically:
- dataConUserTyVarBindersNeedWrapper has been updated to answer "yes"
if there are visible foralls in the type of the data constructor.
- mkDataConRep now uses mkCoreTyLams to generate the big lambda
abstractions (/\a b c. e) in the data con wrapper.
- mkCoreTyLams is a variant of mkCoreLams that applies visibility casts
as needed. It similar in purpose to the pre-existing mkWpForAllCast,
so the common bits have been factored out into mkForAllVisCos.
ConDecl in compiler/Language/Haskell/Syntax/Decls.hs
----------------------------------------------------
The surface syntax representation of a data constructor declaration is
ConDecl. In accordance with the proposal, only GADT syntax is extended
with support for visible forall, so we are interested in ConDeclGADT.
ConDeclGADT's field con_bndrs has been renamed to con_outer_bndrs
and is now accompanied by con_inner_bndrs:
con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass)
con_inner_bndrs :: [HsForAllTelescope pass]
Visible foralls always end up in con_inner_bndrs. The outer binders are
stored and processed separately to support implicit quantification and
the forall-or-nothing rule, a design established by HsSigType.
A side effect of this change is that even in absence of visible foralls,
GHC now permits multiple invisible foralls, e.g.
data T a where { MkT :: forall a b. forall c d. ... -> T a }
But of course, this is done in service of making at least some of these
foralls visible. The entire compiler front-end has been updated to deal
with con_inner_bndrs. See the following modified or added functions:
Parser:
mkGadtDecl in compiler/GHC/Parser/PostProcess.hs
splitLHsGadtTy in compiler/GHC/Hs/Type.hs
Pretty-printer:
pprConDecl in compiler/GHC/Hs/Decls.hs
pprHsForAllTelescope in compiler/GHC/Hs/Type.hs
Renamer:
rnConDecl in compiler/GHC/Rename/Module.hs
bindHsForAllTelescopes in compiler/GHC/Rename/HsType.hs
extractHsForAllTelescopes in compiler/GHC/Rename/HsType.hs
Type checker:
tcConDecl in compiler/GHC/Tc/TyCl.hs
tcGadtConTyVarBndrs in compiler/GHC/Tc/Gen/HsType.hs
Template Haskell
----------------
The TH AST is left unchanged for the moment to avoid breakage. An
attempt to quote or reify a data constructor declaration with visible
forall in its type will result an error:
data ThRejectionReason -- in GHC/HsToCore/Errors/Types.hs
= ...
| ThDataConVisibleForall -- new error constructor
However, as noted in the previous section, GHC now permits multiple
invisible foralls, and TH was updated accordingly. Updated code:
repC in compiler/GHC/HsToCore/Quote.hs
reifyDataCon in compiler/GHC/Tc/Gen/Splice.hs
ppr @Con in libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
Pattern matching
----------------
Everything described above concerns data constructor declarations, but
what about their use sites? Now it is trickier to type check a pattern
match fn(Con a b c)=... because we can no longer assume that a,b,c are
all value arguments. Indeed, some or all of them may very well turn out
to be required type arguments.
To that end, see the changes to:
tcDataConPat in compiler/GHC/Tc/Gen/Pat.hs
splitConTyArgs in compiler/GHC/Tc/Gen/Pat.hs
and the new helpers split_con_ty_args, zip_pats_bndrs.
This is also the reason the TcRnTooManyTyArgsInConPattern error
constructor has been removed. The new code emits TcRnArityMismatch
or TcRnIllegalInvisibleTypePattern.
Summary
-------
DataCon, ConDecl, as well as all related functions have been updated to
support required type arguments in data constructors.
Test cases:
HieGadtConSigs GadtConSigs_th_dump1 GadtConSigs_th_pprint1
T25127_data T25127_data_inst T25127_infix
T25127_newtype T25127_fail_th_quote T25127_fail_arity
TyAppPat_Tricky
Co-authored-by: mniip <mniip(a)mniip.com>
- - - - -
170 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/DataCon.hs-boot
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/PatSyn.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Stg/EnforceEpt/Types.hs
- compiler/GHC/SysTools/Ar.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/Var.hs-boot
- compiler/GHC/Utils/Panic.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/exts/required_type_arguments.rst
- docs/users_guide/using-warnings.rst
- docs/users_guide/using.rst
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- rts/include/stg/MachRegs.h
- testsuite/tests/annotations/should_fail/annfail03.stderr
- testsuite/tests/annotations/should_fail/annfail09.stderr
- testsuite/tests/dependent/should_fail/T16326_Fail6.stderr
- + testsuite/tests/ghc-api/T26120.hs
- + testsuite/tests/ghc-api/T26120.stdout
- testsuite/tests/ghc-api/all.T
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- + testsuite/tests/hiefile/should_run/HieGadtConSigs.hs
- + testsuite/tests/hiefile/should_run/HieGadtConSigs.stdout
- testsuite/tests/hiefile/should_run/all.T
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/quasiquotation/qq001/qq001.stderr
- testsuite/tests/quasiquotation/qq002/qq002.stderr
- testsuite/tests/quasiquotation/qq003/qq003.stderr
- testsuite/tests/quasiquotation/qq004/qq004.stderr
- + testsuite/tests/quotes/LiftErrMsg.hs
- + testsuite/tests/quotes/LiftErrMsg.stderr
- + testsuite/tests/quotes/LiftErrMsgDefer.hs
- + testsuite/tests/quotes/LiftErrMsgDefer.stderr
- + testsuite/tests/quotes/LiftErrMsgTyped.hs
- + testsuite/tests/quotes/LiftErrMsgTyped.stderr
- testsuite/tests/quotes/T10384.stderr
- testsuite/tests/quotes/TH_localname.stderr
- testsuite/tests/quotes/all.T
- + testsuite/tests/rep-poly/T26107.hs
- testsuite/tests/rep-poly/all.T
- testsuite/tests/splice-imports/SI03.stderr
- testsuite/tests/splice-imports/SI05.stderr
- testsuite/tests/splice-imports/SI16.stderr
- testsuite/tests/splice-imports/SI18.stderr
- testsuite/tests/splice-imports/SI20.stderr
- testsuite/tests/splice-imports/SI25.stderr
- testsuite/tests/splice-imports/SI28.stderr
- testsuite/tests/splice-imports/SI31.stderr
- + testsuite/tests/th/GadtConSigs_th_dump1.hs
- + testsuite/tests/th/GadtConSigs_th_dump1.stderr
- + testsuite/tests/th/GadtConSigs_th_pprint1.hs
- + testsuite/tests/th/GadtConSigs_th_pprint1.stderr
- testsuite/tests/th/T16976z.stderr
- testsuite/tests/th/T17820a.stderr
- testsuite/tests/th/T17820b.stderr
- testsuite/tests/th/T17820c.stderr
- testsuite/tests/th/T17820d.stderr
- testsuite/tests/th/T17820e.stderr
- testsuite/tests/th/T20868.stdout
- testsuite/tests/th/T23829_hasty.stderr
- testsuite/tests/th/T23829_hasty_b.stderr
- testsuite/tests/th/T5795.stderr
- testsuite/tests/th/all.T
- + testsuite/tests/typecheck/should_compile/T20873c.hs
- − testsuite/tests/typecheck/should_compile/T22141a.stderr
- − testsuite/tests/typecheck/should_compile/T22141b.stderr
- − testsuite/tests/typecheck/should_compile/T22141c.stderr
- − testsuite/tests/typecheck/should_compile/T22141d.stderr
- − testsuite/tests/typecheck/should_compile/T22141e.stderr
- testsuite/tests/typecheck/should_compile/T23739a.hs
- + testsuite/tests/typecheck/should_compile/TyAppPat_Tricky.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_fail/T20443b.stderr
- − testsuite/tests/typecheck/should_fail/T20873c.hs
- − testsuite/tests/typecheck/should_fail/T20873c.stderr
- testsuite/tests/typecheck/should_compile/T22141a.hs → testsuite/tests/typecheck/should_fail/T22141a.hs
- testsuite/tests/typecheck/should_fail/T22141a.stderr
- testsuite/tests/typecheck/should_compile/T22141b.hs → testsuite/tests/typecheck/should_fail/T22141b.hs
- testsuite/tests/typecheck/should_fail/T22141b.stderr
- testsuite/tests/typecheck/should_compile/T22141c.hs → testsuite/tests/typecheck/should_fail/T22141c.hs
- testsuite/tests/typecheck/should_fail/T22141c.stderr
- testsuite/tests/typecheck/should_compile/T22141d.hs → testsuite/tests/typecheck/should_fail/T22141d.hs
- testsuite/tests/typecheck/should_fail/T22141d.stderr
- testsuite/tests/typecheck/should_compile/T22141e.hs → testsuite/tests/typecheck/should_fail/T22141e.hs
- testsuite/tests/typecheck/should_fail/T22141e.stderr
- testsuite/tests/typecheck/should_compile/T22141e_Aux.hs → testsuite/tests/typecheck/should_fail/T22141e_Aux.hs
- testsuite/tests/typecheck/should_fail/TyAppPat_TooMany.stderr
- testsuite/tests/typecheck/should_fail/all.T
- + testsuite/tests/vdq-rta/should_compile/T25127_data.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_data_inst.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_infix.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_newtype.hs
- testsuite/tests/vdq-rta/should_compile/all.T
- testsuite/tests/vdq-rta/should_fail/T23739_fail_case.hs
- testsuite/tests/vdq-rta/should_fail/T23739_fail_case.stderr
- testsuite/tests/vdq-rta/should_fail/T24159_type_syntax_th_fail.script
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.hs
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.stderr
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.hs
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.stderr
- testsuite/tests/vdq-rta/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/CHANGES.md
- utils/haddock/doc/cheatsheet/haddocks.md
- utils/haddock/doc/markup.rst
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
- + utils/haddock/html-test/ref/RedactTypeSynonyms.html
- + utils/haddock/html-test/src/RedactTypeSynonyms.hs
- + utils/haddock/latex-test/ref/RedactTypeSynonyms/RedactTypeSynonyms.tex
- + utils/haddock/latex-test/src/RedactTypeSynonyms/RedactTypeSynonyms.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4951a1dae3ef176310039e724537af…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4951a1dae3ef176310039e724537af…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Visible forall in GADTs (#25127)
by Marge Bot (＠marge-bot) 21 Jun '25
by Marge Bot (＠marge-bot) 21 Jun '25
21 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9c39917e by Vladislav Zavialov at 2025-06-21T18:06:59-04:00
Visible forall in GADTs (#25127)
Add support for visible dependent quantification `forall a -> t` in
types of data constructors, e.g.
data KindVal a where
K :: forall k.
forall (a::k) -> -- now allowed!
k ->
KindVal a
For details, see docs/users_guide/exts/required_type_arguments.rst,
which has gained a new subsection.
DataCon in compiler/GHC/Core/DataCon.hs
---------------------------------------
The main change in this patch is that DataCon, the Core representation
of a data constructor, now uses a different type to store user-written
type variable binders:
- dcUserTyVarBinders :: [InvisTVBinder]
+ dcUserTyVarBinders :: [TyVarBinder]
where
type TyVarBinder = VarBndr TyVar ForAllTyFlag
type InvisTVBinder = VarBndr TyVar Specificity
and
data Specificity = InferredSpec | SpecifiedSpec
data ForAllTyFlag = Invisible Specificity | Required
This change necessitates some boring, mechanical changes scattered
throughout the diff:
... is now used in place of ...
-----------------+---------------
TyVarBinder | InvisTVBinder
IfaceForAllBndr | IfaceForAllSpecBndr
Specified | SpecifiedSpec
Inferred | InferredSpec
mkForAllTys | mkInvisForAllTys
additionally,
tyVarSpecToBinders -- added or removed calls
ifaceForAllSpecToBndrs -- removed calls
Visibility casts in mkDataConRep
--------------------------------
Type abstractions in Core (/\a. e) always have type (forall a. t)
because coreTyLamForAllTyFlag = Specified. This is also true of data
constructor workers. So we may be faced with the following:
data con worker: (forall a. blah)
data con wrapper: (forall a -> blah)
In this case the wrapper must use a visibility cast (e |> ForAllCo ...)
with appropriately set fco_vis{L,R}. Relevant functions:
mkDataConRep in compiler/GHC/Types/Id/Make.hs
dataConUserTyVarBindersNeedWrapper in compiler/GHC/Core/DataCon.hs
mkForAllVisCos in compiler/GHC/Core/Coercion.hs
mkCoreTyLams in compiler/GHC/Core/Make.hs
mkWpForAllCast in compiler/GHC/Tc/Types/Evidence.hs
More specifically:
- dataConUserTyVarBindersNeedWrapper has been updated to answer "yes"
if there are visible foralls in the type of the data constructor.
- mkDataConRep now uses mkCoreTyLams to generate the big lambda
abstractions (/\a b c. e) in the data con wrapper.
- mkCoreTyLams is a variant of mkCoreLams that applies visibility casts
as needed. It similar in purpose to the pre-existing mkWpForAllCast,
so the common bits have been factored out into mkForAllVisCos.
ConDecl in compiler/Language/Haskell/Syntax/Decls.hs
----------------------------------------------------
The surface syntax representation of a data constructor declaration is
ConDecl. In accordance with the proposal, only GADT syntax is extended
with support for visible forall, so we are interested in ConDeclGADT.
ConDeclGADT's field con_bndrs has been renamed to con_outer_bndrs
and is now accompanied by con_inner_bndrs:
con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass)
con_inner_bndrs :: [HsForAllTelescope pass]
Visible foralls always end up in con_inner_bndrs. The outer binders are
stored and processed separately to support implicit quantification and
the forall-or-nothing rule, a design established by HsSigType.
A side effect of this change is that even in absence of visible foralls,
GHC now permits multiple invisible foralls, e.g.
data T a where { MkT :: forall a b. forall c d. ... -> T a }
But of course, this is done in service of making at least some of these
foralls visible. The entire compiler front-end has been updated to deal
with con_inner_bndrs. See the following modified or added functions:
Parser:
mkGadtDecl in compiler/GHC/Parser/PostProcess.hs
splitLHsGadtTy in compiler/GHC/Hs/Type.hs
Pretty-printer:
pprConDecl in compiler/GHC/Hs/Decls.hs
pprHsForAllTelescope in compiler/GHC/Hs/Type.hs
Renamer:
rnConDecl in compiler/GHC/Rename/Module.hs
bindHsForAllTelescopes in compiler/GHC/Rename/HsType.hs
extractHsForAllTelescopes in compiler/GHC/Rename/HsType.hs
Type checker:
tcConDecl in compiler/GHC/Tc/TyCl.hs
tcGadtConTyVarBndrs in compiler/GHC/Tc/Gen/HsType.hs
Template Haskell
----------------
The TH AST is left unchanged for the moment to avoid breakage. An
attempt to quote or reify a data constructor declaration with visible
forall in its type will result an error:
data ThRejectionReason -- in GHC/HsToCore/Errors/Types.hs
= ...
| ThDataConVisibleForall -- new error constructor
However, as noted in the previous section, GHC now permits multiple
invisible foralls, and TH was updated accordingly. Updated code:
repC in compiler/GHC/HsToCore/Quote.hs
reifyDataCon in compiler/GHC/Tc/Gen/Splice.hs
ppr @Con in libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
Pattern matching
----------------
Everything described above concerns data constructor declarations, but
what about their use sites? Now it is trickier to type check a pattern
match fn(Con a b c)=... because we can no longer assume that a,b,c are
all value arguments. Indeed, some or all of them may very well turn out
to be required type arguments.
To that end, see the changes to:
tcDataConPat in compiler/GHC/Tc/Gen/Pat.hs
splitConTyArgs in compiler/GHC/Tc/Gen/Pat.hs
and the new helpers split_con_ty_args, zip_pats_bndrs.
This is also the reason the TcRnTooManyTyArgsInConPattern error
constructor has been removed. The new code emits TcRnArityMismatch
or TcRnIllegalInvisibleTypePattern.
Summary
-------
DataCon, ConDecl, as well as all related functions have been updated to
support required type arguments in data constructors.
Test cases:
HieGadtConSigs GadtConSigs_th_dump1 GadtConSigs_th_pprint1
T25127_data T25127_data_inst T25127_infix
T25127_newtype T25127_fail_th_quote T25127_fail_arity
TyAppPat_Tricky
Co-authored-by: mniip <mniip(a)mniip.com>
- - - - -
9562cbd3 by Teo Camarasu at 2025-06-21T18:07:00-04:00
linters: lint-whitespace: bump upper-bound for containers
The version of containers was bumped in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13989
- - - - -
82 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/DataCon.hs-boot
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/PatSyn.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/Var.hs-boot
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/exts/required_type_arguments.rst
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- linters/lint-whitespace/lint-whitespace.cabal
- testsuite/tests/dependent/should_fail/T16326_Fail6.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- + testsuite/tests/hiefile/should_run/HieGadtConSigs.hs
- + testsuite/tests/hiefile/should_run/HieGadtConSigs.stdout
- testsuite/tests/hiefile/should_run/all.T
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/printer/T18791.stderr
- + testsuite/tests/th/GadtConSigs_th_dump1.hs
- + testsuite/tests/th/GadtConSigs_th_dump1.stderr
- + testsuite/tests/th/GadtConSigs_th_pprint1.hs
- + testsuite/tests/th/GadtConSigs_th_pprint1.stderr
- testsuite/tests/th/T20868.stdout
- testsuite/tests/th/all.T
- testsuite/tests/typecheck/should_compile/T23739a.hs
- + testsuite/tests/typecheck/should_compile/TyAppPat_Tricky.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_fail/T20443b.stderr
- testsuite/tests/typecheck/should_fail/TyAppPat_TooMany.stderr
- + testsuite/tests/vdq-rta/should_compile/T25127_data.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_data_inst.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_infix.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_newtype.hs
- testsuite/tests/vdq-rta/should_compile/all.T
- testsuite/tests/vdq-rta/should_fail/T24159_type_syntax_th_fail.script
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.hs
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.stderr
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.hs
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.stderr
- testsuite/tests/vdq-rta/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d786da67f7ae528d8550a79762306…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d786da67f7ae528d8550a79762306…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26115] Restore the missing overlap checking in one-shot solving
by Simon Peyton Jones (＠simonpj) 21 Jun '25
by Simon Peyton Jones (＠simonpj) 21 Jun '25
21 Jun '25
Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC
Commits:
e5017601 by Simon Peyton Jones at 2025-06-21T22:56:35+01:00
Restore the missing overlap checking in one-shot solving
I have done this by re-using TcSSpecPrag mode, which is a
bit of a hack. Certainly need docs.
- - - - -
3 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Validity.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -767,6 +767,7 @@ tryShortCutSolver try_short_cut dict_w@(DictCt { di_ev = ev_w })
-- Enabled by the -fsolve-constant-dicts flag
-> tryTcS $ -- tryTcS tries to completely solve some contraints
+ setTcSMode TcSSpecPrag $
do { updInertSet zap_cans
; solveSimpleWanteds (unitBag (CDictCan dict_w)) }
@@ -899,7 +900,7 @@ matchClassInst dflags inerts clas tys loc
; return local_res }
NoInstance -- No local instances, so try global ones
- -> do { global_res <- matchGlobalInst dflags False clas tys loc
+ -> do { global_res <- matchGlobalInst dflags clas tys loc
; warn_custom_warn_instance global_res loc
-- See Note [Implementation of deprecated instances]
; traceTcS "} matchClassInst global result" $ ppr global_res
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -2020,12 +2020,11 @@ instFlexiXTcM subst (tv:tvs)
subst' = extendTvSubstWithClone subst tv tv'
; instFlexiXTcM subst' tvs }
-matchGlobalInst :: DynFlags
- -> Bool -- True <=> caller is the short-cut solver
- -- See Note [Shortcut solving: overlap]
- -> Class -> [Type] -> CtLoc -> TcS TcM.ClsInstResult
-matchGlobalInst dflags short_cut cls tys loc
- = wrapTcS $ TcM.matchGlobalInst dflags short_cut cls tys (Just loc)
+matchGlobalInst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS TcM.ClsInstResult
+matchGlobalInst dflags cls tys loc
+ = do { mode <- getTcSMode
+ ; let short_cut = mode == TcSSpecPrag
+ ; wrapTcS $ TcM.matchGlobalInst dflags short_cut cls tys (Just loc) }
tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar])
tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -26,13 +26,13 @@ import GHC.Data.Maybe
import GHC.Tc.Utils.Unify ( tcSubTypeAmbiguity )
import GHC.Tc.Solver ( simplifyAmbiguityCheck )
import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo(..) )
-import GHC.Tc.Utils.TcType
+import GHC.Tc.Instance.FunDeps
+import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Rank
import GHC.Tc.Errors.Types
+import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Monad
-import GHC.Tc.Instance.FunDeps
-import GHC.Tc.Instance.Family
import GHC.Tc.Zonk.TcType
import GHC.Builtin.Types
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e50176014c7484861ed3ba63e8b3359…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e50176014c7484861ed3ba63e8b3359…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Deprecate -Wdata-kinds-tc, make DataKinds issues in typechecker become errors
by Marge Bot (＠marge-bot) 21 Jun '25
by Marge Bot (＠marge-bot) 21 Jun '25
21 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
d3e60e97 by Ryan Scott at 2025-06-18T22:29:21-04:00
Deprecate -Wdata-kinds-tc, make DataKinds issues in typechecker become errors
!11314 introduced the `-Wdata-kinds-tc` warning as part of a fix for #22141.
This was a temporary stopgap measure to allow users who were accidentally
relying on code which needed the `DataKinds` extension in order to typecheck
without having to explicitly enable the extension.
Now that some amount of time has passed, this patch deprecates
`-Wdata-kinds-tc` and upgrades any `DataKinds`-related issues in the
typechecker (which were previously warnings) into errors.
- - - - -
fd5b5177 by Ryan Hendrickson at 2025-06-18T22:30:06-04:00
haddock: Add redact-type-synonyms pragma
`{-# OPTIONS_HADDOCK redact-type-synonyms #-}` pragma will hide the RHS
of type synonyms, and display the result kind instead, if the RHS
contains any unexported types.
- - - - -
008768ea by Vladislav Zavialov at 2025-06-21T13:04:34-04:00
Visible forall in GADTs (#25127)
Add support for visible dependent quantification `forall a -> t` in
types of data constructors, e.g.
data KindVal a where
K :: forall k.
forall (a::k) -> -- now allowed!
k ->
KindVal a
For details, see docs/users_guide/exts/required_type_arguments.rst,
which has gained a new subsection.
DataCon in compiler/GHC/Core/DataCon.hs
---------------------------------------
The main change in this patch is that DataCon, the Core representation
of a data constructor, now uses a different type to store user-written
type variable binders:
- dcUserTyVarBinders :: [InvisTVBinder]
+ dcUserTyVarBinders :: [TyVarBinder]
where
type TyVarBinder = VarBndr TyVar ForAllTyFlag
type InvisTVBinder = VarBndr TyVar Specificity
and
data Specificity = InferredSpec | SpecifiedSpec
data ForAllTyFlag = Invisible Specificity | Required
This change necessitates some boring, mechanical changes scattered
throughout the diff:
... is now used in place of ...
-----------------+---------------
TyVarBinder | InvisTVBinder
IfaceForAllBndr | IfaceForAllSpecBndr
Specified | SpecifiedSpec
Inferred | InferredSpec
mkForAllTys | mkInvisForAllTys
additionally,
tyVarSpecToBinders -- added or removed calls
ifaceForAllSpecToBndrs -- removed calls
Visibility casts in mkDataConRep
--------------------------------
Type abstractions in Core (/\a. e) always have type (forall a. t)
because coreTyLamForAllTyFlag = Specified. This is also true of data
constructor workers. So we may be faced with the following:
data con worker: (forall a. blah)
data con wrapper: (forall a -> blah)
In this case the wrapper must use a visibility cast (e |> ForAllCo ...)
with appropriately set fco_vis{L,R}. Relevant functions:
mkDataConRep in compiler/GHC/Types/Id/Make.hs
dataConUserTyVarBindersNeedWrapper in compiler/GHC/Core/DataCon.hs
mkForAllVisCos in compiler/GHC/Core/Coercion.hs
mkCoreTyLams in compiler/GHC/Core/Make.hs
mkWpForAllCast in compiler/GHC/Tc/Types/Evidence.hs
More specifically:
- dataConUserTyVarBindersNeedWrapper has been updated to answer "yes"
if there are visible foralls in the type of the data constructor.
- mkDataConRep now uses mkCoreTyLams to generate the big lambda
abstractions (/\a b c. e) in the data con wrapper.
- mkCoreTyLams is a variant of mkCoreLams that applies visibility casts
as needed. It similar in purpose to the pre-existing mkWpForAllCast,
so the common bits have been factored out into mkForAllVisCos.
ConDecl in compiler/Language/Haskell/Syntax/Decls.hs
----------------------------------------------------
The surface syntax representation of a data constructor declaration is
ConDecl. In accordance with the proposal, only GADT syntax is extended
with support for visible forall, so we are interested in ConDeclGADT.
ConDeclGADT's field con_bndrs has been renamed to con_outer_bndrs
and is now accompanied by con_inner_bndrs:
con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass)
con_inner_bndrs :: [HsForAllTelescope pass]
Visible foralls always end up in con_inner_bndrs. The outer binders are
stored and processed separately to support implicit quantification and
the forall-or-nothing rule, a design established by HsSigType.
A side effect of this change is that even in absence of visible foralls,
GHC now permits multiple invisible foralls, e.g.
data T a where { MkT :: forall a b. forall c d. ... -> T a }
But of course, this is done in service of making at least some of these
foralls visible. The entire compiler front-end has been updated to deal
with con_inner_bndrs. See the following modified or added functions:
Parser:
mkGadtDecl in compiler/GHC/Parser/PostProcess.hs
splitLHsGadtTy in compiler/GHC/Hs/Type.hs
Pretty-printer:
pprConDecl in compiler/GHC/Hs/Decls.hs
pprHsForAllTelescope in compiler/GHC/Hs/Type.hs
Renamer:
rnConDecl in compiler/GHC/Rename/Module.hs
bindHsForAllTelescopes in compiler/GHC/Rename/HsType.hs
extractHsForAllTelescopes in compiler/GHC/Rename/HsType.hs
Type checker:
tcConDecl in compiler/GHC/Tc/TyCl.hs
tcGadtConTyVarBndrs in compiler/GHC/Tc/Gen/HsType.hs
Template Haskell
----------------
The TH AST is left unchanged for the moment to avoid breakage. An
attempt to quote or reify a data constructor declaration with visible
forall in its type will result an error:
data ThRejectionReason -- in GHC/HsToCore/Errors/Types.hs
= ...
| ThDataConVisibleForall -- new error constructor
However, as noted in the previous section, GHC now permits multiple
invisible foralls, and TH was updated accordingly. Updated code:
repC in compiler/GHC/HsToCore/Quote.hs
reifyDataCon in compiler/GHC/Tc/Gen/Splice.hs
ppr @Con in libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
Pattern matching
----------------
Everything described above concerns data constructor declarations, but
what about their use sites? Now it is trickier to type check a pattern
match fn(Con a b c)=... because we can no longer assume that a,b,c are
all value arguments. Indeed, some or all of them may very well turn out
to be required type arguments.
To that end, see the changes to:
tcDataConPat in compiler/GHC/Tc/Gen/Pat.hs
splitConTyArgs in compiler/GHC/Tc/Gen/Pat.hs
and the new helpers split_con_ty_args, zip_pats_bndrs.
This is also the reason the TcRnTooManyTyArgsInConPattern error
constructor has been removed. The new code emits TcRnArityMismatch
or TcRnIllegalInvisibleTypePattern.
Summary
-------
DataCon, ConDecl, as well as all related functions have been updated to
support required type arguments in data constructors.
Test cases:
HieGadtConSigs GadtConSigs_th_dump1 GadtConSigs_th_pprint1
T25127_data T25127_data_inst T25127_infix
T25127_newtype T25127_fail_th_quote T25127_fail_arity
TyAppPat_Tricky
Co-authored-by: mniip <mniip(a)mniip.com>
- - - - -
8d786da6 by Teo Camarasu at 2025-06-21T13:04:35-04:00
linters: lint-whitespace: bump upper-bound for containers
The version of containers was bumped in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13989
- - - - -
122 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/DataCon.hs-boot
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/PatSyn.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/Var.hs-boot
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/exts/required_type_arguments.rst
- docs/users_guide/using-warnings.rst
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- linters/lint-whitespace/lint-whitespace.cabal
- testsuite/tests/dependent/should_fail/T16326_Fail6.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- + testsuite/tests/hiefile/should_run/HieGadtConSigs.hs
- + testsuite/tests/hiefile/should_run/HieGadtConSigs.stdout
- testsuite/tests/hiefile/should_run/all.T
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/printer/T18791.stderr
- + testsuite/tests/th/GadtConSigs_th_dump1.hs
- + testsuite/tests/th/GadtConSigs_th_dump1.stderr
- + testsuite/tests/th/GadtConSigs_th_pprint1.hs
- + testsuite/tests/th/GadtConSigs_th_pprint1.stderr
- testsuite/tests/th/T20868.stdout
- testsuite/tests/th/all.T
- + testsuite/tests/typecheck/should_compile/T20873c.hs
- − testsuite/tests/typecheck/should_compile/T22141a.stderr
- − testsuite/tests/typecheck/should_compile/T22141b.stderr
- − testsuite/tests/typecheck/should_compile/T22141c.stderr
- − testsuite/tests/typecheck/should_compile/T22141d.stderr
- − testsuite/tests/typecheck/should_compile/T22141e.stderr
- testsuite/tests/typecheck/should_compile/T23739a.hs
- + testsuite/tests/typecheck/should_compile/TyAppPat_Tricky.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_fail/T20443b.stderr
- − testsuite/tests/typecheck/should_fail/T20873c.hs
- − testsuite/tests/typecheck/should_fail/T20873c.stderr
- testsuite/tests/typecheck/should_compile/T22141a.hs → testsuite/tests/typecheck/should_fail/T22141a.hs
- testsuite/tests/typecheck/should_fail/T22141a.stderr
- testsuite/tests/typecheck/should_compile/T22141b.hs → testsuite/tests/typecheck/should_fail/T22141b.hs
- testsuite/tests/typecheck/should_fail/T22141b.stderr
- testsuite/tests/typecheck/should_compile/T22141c.hs → testsuite/tests/typecheck/should_fail/T22141c.hs
- testsuite/tests/typecheck/should_fail/T22141c.stderr
- testsuite/tests/typecheck/should_compile/T22141d.hs → testsuite/tests/typecheck/should_fail/T22141d.hs
- testsuite/tests/typecheck/should_fail/T22141d.stderr
- testsuite/tests/typecheck/should_compile/T22141e.hs → testsuite/tests/typecheck/should_fail/T22141e.hs
- testsuite/tests/typecheck/should_fail/T22141e.stderr
- testsuite/tests/typecheck/should_compile/T22141e_Aux.hs → testsuite/tests/typecheck/should_fail/T22141e_Aux.hs
- testsuite/tests/typecheck/should_fail/TyAppPat_TooMany.stderr
- testsuite/tests/typecheck/should_fail/all.T
- + testsuite/tests/vdq-rta/should_compile/T25127_data.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_data_inst.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_infix.hs
- + testsuite/tests/vdq-rta/should_compile/T25127_newtype.hs
- testsuite/tests/vdq-rta/should_compile/all.T
- testsuite/tests/vdq-rta/should_fail/T23739_fail_case.hs
- testsuite/tests/vdq-rta/should_fail/T23739_fail_case.stderr
- testsuite/tests/vdq-rta/should_fail/T24159_type_syntax_th_fail.script
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.hs
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.stderr
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.hs
- + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.stderr
- testsuite/tests/vdq-rta/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/CHANGES.md
- utils/haddock/doc/cheatsheet/haddocks.md
- utils/haddock/doc/markup.rst
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
- + utils/haddock/html-test/ref/RedactTypeSynonyms.html
- + utils/haddock/html-test/src/RedactTypeSynonyms.hs
- + utils/haddock/latex-test/ref/RedactTypeSynonyms/RedactTypeSynonyms.tex
- + utils/haddock/latex-test/src/RedactTypeSynonyms/RedactTypeSynonyms.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca1f588b45d1fb4a0c2e6149b2bdcd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca1f588b45d1fb4a0c2e6149b2bdcd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
21 Jun '25
Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC
Commits:
1c9b5d4a by Alan Zimmerman at 2025-06-21T15:40:56+01:00
Some cleanup
- - - - -
2c673901 by Alan Zimmerman at 2025-06-21T16:41:35+01:00
GHC_CPP: Working on improving error reporting
- - - - -
6 changed files:
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PreProcess.hs
- compiler/GHC/Parser/PreProcess/Macro.hs
- compiler/GHC/Parser/PreProcess/State.hs
- testsuite/tests/ghc-cpp/GhcCpp02.stderr
- utils/check-cpp/PreProcess.hs
Changes:
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -59,7 +59,6 @@ module GHC.Parser.Lexer (
Token(..), lexer, lexerDbg,
ParserOpts(..), mkParserOpts,
PState (..), initParserState, initPragState,
- PSavedAlrState(..), getAlrState, setAlrState,
startSkipping, stopSkipping,
P(..), ParseResult(POk, PFailed),
allocateComments, allocatePriorComments, allocateFinalComments,
@@ -273,7 +272,6 @@ $tab { warnTab }
-- set.
"{-" / { isNormalComment } { nested_comment }
--- "/*" / { ifExtension GhcCppBit } { cpp_comment }
-- Single-line comments are a bit tricky. Haskell 98 says that two or
-- more dashes followed by a symbol should be parsed as a varsym, so we
@@ -1351,6 +1349,7 @@ hopefully_open_brace :: Action p
hopefully_open_brace span buf len buf2
= do relaxed <- getBit RelaxedLayoutBit
ctx <- getContext
+ -- See Note [GHC_CPP saved offset]
offset <- getOffset
let
isOK = relaxed ||
@@ -1592,15 +1591,6 @@ nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLe
dropTrailingDec "-}" = ""
dropTrailingDec (x:xs) = x:dropTrailingDec xs
-cpp_comment :: Action p
-cpp_comment span buf len _buf2 = {-# SCC "cpp_comment" #-} do
- l <- getLastLocIncludingComments
- let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span
- input <- getInput
- -- Include decorator in comment
- let start_decorator = reverse $ lexemeToString buf len
- cpp_comment_logic endComment start_decorator input span
-
{-# INLINE nested_comment_logic #-}
-- | Includes the trailing '-}' decorators
-- drop the last two elements with the callback if you don't want them to be included
@@ -1635,31 +1625,6 @@ nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) i
Just (_,_) -> go ('\n':commentAcc) n input
Just (c,input) -> go (c:commentAcc) n input
-{-# INLINE cpp_comment_logic #-}
--- | Includes the trailing '*/' decorators
--- drop the last two elements with the callback if you don't want them to be included
-cpp_comment_logic
- :: (AlexInput -> Located String -> P p (PsLocated Token)) -- ^ Continuation that gets the rest of the input and the lexed comment
- -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '/*' in the comment
- -> AlexInput
- -> PsSpan
- -> P p (PsLocated Token)
-cpp_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input
- where
- go commentAcc 0 input@(AI end_loc _) = do
- let comment = reverse commentAcc
- cspan = mkSrcSpanPs $ mkPsSpan (psSpanStart span) end_loc
- lcomment = L cspan comment
- endComment input lcomment
- go commentAcc n input = case alexGetChar' input of
- Nothing -> errBrace input (psRealSpan span)
- Just ('*',input) -> case alexGetChar' input of
- Nothing -> errBrace input (psRealSpan span)
- Just ('/',input) -> go ('/':'*':commentAcc) (n-1) input -- '/'
- Just (_,_) -> go ('*':commentAcc) n input
- Just (c,input) -> go (c:commentAcc) n input
-
-
ghcCppSet :: P p Bool
ghcCppSet = do
exts <- getExts
@@ -1775,9 +1740,12 @@ linePrag span buf len buf2 = do
usePosPrags <- getBit UsePosPragsBit
if usePosPrags
then begin line_prag2 span buf len buf2
- -- else let !src = lexemeToFastString buf len
- -- in return (L span (ITline_prag (SourceText src)))
- else nested_comment span buf len buf2
+ else do
+ useGhcCpp <- getBit GhcCppBit
+ if useGhcCpp
+ then nested_comment span buf len buf2
+ else let !src = lexemeToFastString buf len
+ in return (L span (ITline_prag (SourceText src)))
-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
-- of updating the position in 'PState'
@@ -2166,6 +2134,7 @@ do_bol span _str _len _buf2 = do
-- See Note [Nested comment line pragmas]
b <- getBit InNestedCommentBit
if b then return (L span ITcomment_line_prag) else do
+ -- See Note [GHC_CPP saved offset]
resetOffset
(pos, gen_semic) <- getOffside
case pos of
@@ -2216,6 +2185,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
new_layout_context :: Bool -> Bool -> Token -> Action p
new_layout_context strict gen_semic tok span _buf len _buf2 = do
_ <- popLexState
+ -- See Note [GHC_CPP saved offset]
current_col <- getOffset
let offset = current_col - len
ctx <- getContext
@@ -2670,6 +2640,7 @@ data PState a = PState {
pp :: !a,
-- If a CPP directive occurs in the layout context, we need to
-- store the prior column so any alr processing can continue.
+ -- See Note [GHC_CPP saved offset]
pp_last_col :: !(Maybe Int)
}
-- last_loc and last_len are used when generating error messages,
@@ -2684,32 +2655,6 @@ data PState a = PState {
-- of the action, it is the *current* token. Do I understand
-- correctly?
-data PSavedAlrState = PSavedAlrState {
- -- s_warnings :: Messages PsMessage,
- -- s_errors :: Messages PsMessage,
- s_lex_state :: [Int],
- s_context :: [LayoutContext],
- s_alr_pending_implicit_tokens :: [PsLocated Token],
- s_alr_next_token :: Maybe (PsLocated Token),
- s_alr_last_loc :: PsSpan,
- s_alr_context :: [ALRContext],
- s_alr_expecting_ocurly :: Maybe ALRLayout,
- s_alr_justClosedExplicitLetBlock :: Bool,
- s_last_col :: Int
- }
-
-
--- -- | Use for emulating (limited) CPP preprocessing in GHC.
--- -- TODO: move this into PreProcess, and make a param on PState
--- data PpState = PpState {
--- pp_defines :: !(Map String [String]),
--- pp_continuation :: ![Located Token],
--- -- pp_context :: ![PpContext],
--- pp_context :: ![Token], -- What preprocessor directive we are currently processing
--- pp_accepting :: !Bool
--- }
--- deriving (Show)
-
data PpContext = PpContextIf [Located Token]
deriving (Show)
@@ -2825,7 +2770,7 @@ getLastBufCur = P $ \s@(PState { last_buf_cur = last_buf_cur }) -> POk s last_bu
getLastLen :: P p Int
getLastLen = P $ \s@(PState { last_len = last_len }) -> POk s last_len
--- see Note [TBD]
+-- See Note [GHC_CPP saved offset]
getOffset :: P p Int
getOffset = P $ \s@(PState { pp_last_col = last_col,
loc = l}) ->
@@ -2835,74 +2780,55 @@ getOffset = P $ \s@(PState { pp_last_col = last_col,
-- (fromMaybe (srcLocCol (psRealLoc l)) last_col)
in POk s { pp_last_col = Nothing} offset
+-- See Note [GHC_CPP saved offset]
resetOffset :: P p ()
resetOffset = P $ \s -> POk s { pp_last_col = Nothing} ()
+{- Note [GHC_CPP saved offset]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The layout processing machinery examines the offset of the previous
+line when doing its calculations.
+
+When GHC_CPP is used, a set of CPP directives may ignore some number
+of preceding lines, each of which has a different offset.
+
+We deal with this as follows
+
+- When we start skipping lines due to CPP we store the offset of the
+ line before the CPP directive
+- We explicitly ask for the offset using `getOffset` when doing layout
+ calculations
+- If there is a stored offset, we use that instead of the prior line
+ offset
+
+-}
+
startSkipping :: P p ()
startSkipping = do
pushLexState skipping
-- pushLexState (trace ("startSkipping:" ++ show skipping) skipping)
-stopSkipping :: P p Int
+stopSkipping :: P p ()
stopSkipping = do
- -- popLexState
- ret <- popLexState
+ _ <- popLexState
-- We just processed a CPP directive, which included a trailing newline.
-- To properly sync up, we now need to ensure that `do_bol` processing occurs.
- -- But this call does not emit a token.
- -- Maybe it should be an argument to lexToken instead?
- -- Alternatively, push the input location to the previous char.
- AI ps buf <- getInput
- last_buf_cur <- getLastBufCur
- last_loc <- getLastLoc
+ -- But this call does not emit a token, so we instead
+ -- change the input location to the previous char, the newline
+ AI _ps buf <- getInput
last_tk <- getLastTk
case last_tk of
Strict.Just (L l _) -> do
let ps' = PsLoc (realSrcSpanEnd (psRealSpan l)) (bufSpanEnd (psBufSpan l))
let cur' = (cur buf) - 1
- -- let cur' = trace ("stopSkipping:(cur',ps'):" ++ show (cur'',ps')) cur''
setInput (AI ps' (buf { cur = cur'}))
_ -> return ()
- -- return $ trace ("stopSkipping: (ps, cur buf, last_loc, last_buf_cur, last_tk):" ++ show (ps, cur buf, last_loc, last_buf_cur, last_tk)) ret
- return ret
-- old <- popLexState
-- return (trace ("stopSkipping:" ++ show old) old)
-getAlrState :: P p PSavedAlrState
-getAlrState = P $ \s@(PState {loc=l}) -> POk s
- PSavedAlrState {
- -- s_warnings = warnings s,
- -- s_errors = errors s,
- -- s_lex_state = lex_state s,
- s_lex_state = lex_state s,
- s_context = context s,
- s_alr_pending_implicit_tokens = alr_pending_implicit_tokens s,
- s_alr_next_token = alr_next_token s,
- s_alr_last_loc = alr_last_loc s,
- s_alr_context = alr_context s,
- s_alr_expecting_ocurly = alr_expecting_ocurly s,
- s_alr_justClosedExplicitLetBlock = alr_justClosedExplicitLetBlock s,
- s_last_col = srcLocCol (psRealLoc l)
- }
-
-setAlrState :: PSavedAlrState -> P p ()
-setAlrState ss = P $ \s -> POk s {
- -- errors = s_errors ss,
- -- warnings = s_warnings ss,
- lex_state = s_lex_state ss,
- context = s_context ss,
- alr_pending_implicit_tokens = s_alr_pending_implicit_tokens ss,
- alr_next_token = s_alr_next_token ss,
- alr_last_loc = s_alr_last_loc ss,
- alr_context = s_alr_context ss,
- alr_expecting_ocurly = s_alr_expecting_ocurly ss,
- alr_justClosedExplicitLetBlock = s_alr_justClosedExplicitLetBlock ss,
- pp_last_col = Just (s_last_col ss)
- } ()
-
-
{-# INLINE alexGetChar' #-}
-- This version does not squash unicode characters, it is used when
@@ -3199,6 +3125,7 @@ disableHaddock opts = upd_bitmap (xunset HaddockBit)
where
upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) }
+-- TODO:AZ check which of these are actually needed,
enableGhcCpp :: ParserOpts -> ParserOpts
enableGhcCpp = enableExtBit GhcCppBit
@@ -3881,8 +3808,6 @@ warn_unknown_prag prags span buf len buf2 = do
%************************************************************************
-}
--- TODO:AZ: we should have only mkParensEpToks. Delete mkParensEpAnn, mkParensLocs
-
-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'EpToken' values for the opening and closing bordering on the start
-- and end of the span
=====================================
compiler/GHC/Parser/PreProcess.hs
=====================================
@@ -14,8 +14,8 @@ module GHC.Parser.PreProcess (
) where
import Data.List (intercalate, sortBy)
-import Data.Maybe (fromMaybe, listToMaybe)
import Data.Map qualified as Map
+import Data.Maybe (fromMaybe, listToMaybe)
import Debug.Trace (trace)
import GHC.Data.FastString
import GHC.Data.Strict qualified as Strict
@@ -23,6 +23,7 @@ import GHC.Data.StringBuffer
import GHC.Driver.DynFlags (DynFlags, xopt)
import GHC.LanguageExtensions qualified as LangExt
import GHC.Parser.Errors.Ppr ()
+import GHC.Parser.Errors.Types (PsMessage (PsErrGhcCpp))
import GHC.Parser.Lexer (P (..), PState (..), ParseResult (..), Token (..))
import GHC.Parser.Lexer qualified as Lexer
import GHC.Parser.PreProcess.Macro
@@ -34,7 +35,6 @@ import GHC.Types.SrcLoc
import GHC.Utils.Error
import GHC.Utils.Outputable (text)
import GHC.Utils.Panic.Plain (panic)
-import GHC.Parser.Errors.Types (PsMessage(PsErrGhcCpp))
-- ---------------------------------------------------------------------
@@ -42,9 +42,10 @@ dumpGhcCpp :: DynFlags -> PState PpState -> SDoc
dumpGhcCpp dflags pst = output
where
ghc_cpp_enabled = xopt LangExt.GhcCpp dflags
- output = if ghc_cpp_enabled
- then text $ sepa ++ defines ++ sepa ++ final ++ sepa
- else text "GHC_CPP not enabled"
+ output =
+ if ghc_cpp_enabled
+ then text $ sepa ++ defines ++ sepa ++ final ++ sepa
+ else text "GHC_CPP not enabled"
-- Note: pst is the state /before/ the parser runs, so we can use it to lex.
(pst_final, bare_toks) = lexAll pst
comments = reverse (Lexer.comment_q pst_final)
@@ -76,6 +77,7 @@ renderCombinedToks toks = showCppTokenStream toks
-- ---------------------------------------------------------------------
-- addSourceToTokens copied here to unbreak an import loop.
-- It should probably move somewhere else
+-- TODO: We should be able to do away with this once #26095 is done
{- | Given a source location and a StringBuffer corresponding to this
location, return a rich token stream with the source associated to the
@@ -105,7 +107,8 @@ addSourceToTokens loc0 buf0 (t@(L sp _) : ts) =
-- ---------------------------------------------------------------------
--- Tweaked from showRichTokenStream
+-- Tweaked from showRichTokenStream, to add markers per line if it is
+-- currently active or not
showCppTokenStream :: [(Located Token, String)] -> String
showCppTokenStream ts0 = go startLoc ts0 ""
where
@@ -196,7 +199,7 @@ ppLexer queueComments cont =
ppLexer queueComments cont
in
case tk of
- -- case (trace ("M.ppLexer:tk=" ++ show (unLoc tk)) tk) of
+ -- case (trace ("M.ppLexer:tk=" ++ show (unLoc tk)) tk) of
L _ ITeof -> do
mInp <- popIncludeLoc
case mInp of
@@ -219,13 +222,11 @@ ppLexer queueComments cont =
case mdump of
Just dump ->
-- We have a dump of the state, put it into an ignored token
+ -- AZ: TODO: is this actually useful?
contIgnoreTok (L l (ITcpp continuation (appendFS s (fsLit dump)) sp))
Nothing -> contIgnoreTok tk
else contInner tk
L _ (ITcppIgnored _ _) -> contIgnoreTok tk
- L _ (ITline_prag _) -> do
- setInLinePragma True
- contIgnoreTok tk
_ -> do
state <- getCppState
inLinePragma <- getInLinePragma
@@ -253,7 +254,7 @@ processCppToks fs = do
-- Combine any prior continuation tokens
cs <- popContinuation
let loc = combineLocs fs (fromMaybe fs (listToMaybe cs))
- processCpp loc (concat $ reverse $ map get (fs:cs))
+ processCpp loc (concat $ reverse $ map get (fs : cs))
processCpp :: SrcSpan -> String -> PP (Maybe String)
processCpp loc s = do
@@ -262,13 +263,11 @@ processCpp loc s = do
then return (Just "\ndumped state\n")
else do
case directive of
- Left err -> Lexer.addError $ mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp (text err)
+ Left err -> Lexer.addError $ mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp (text err)
Right (CppInclude filename) -> do
ppInclude filename
- Right (CppDefine name args def) -> do
- ppDefine (MacroName name args) def
- Right (CppUndef name) -> do
- ppUndef name
+ Right (CppDefine name args def) -> ppDefine (MacroName name args) def
+ Right (CppUndef name) -> ppUndef name
Right (CppIf cond) -> do
val <- cppCond loc cond
ar <- pushAccepting val
=====================================
compiler/GHC/Parser/PreProcess/Macro.hs
=====================================
@@ -37,12 +37,15 @@ import Data.Map qualified as Map
import Data.Maybe
import Data.Semigroup qualified as S
+import GHC.Driver.Errors.Types (PsMessage)
+import GHC.Parser.Lexer qualified as Lexer
import GHC.Parser.PreProcess.Eval
import GHC.Parser.PreProcess.ParsePP
import GHC.Parser.PreProcess.Parser qualified as Parser
import GHC.Parser.PreProcess.ParserM
import GHC.Parser.PreProcess.State
import GHC.Prelude
+import GHC.Types.Error (MsgEnvelope)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic (panic)
@@ -54,58 +57,84 @@ cppCond :: SrcSpan -> String -> PP Bool
cppCond loc str = do
s <- getPpState
expanded <- expand loc (pp_defines s) str
- v <- case Parser.parseExpr expanded of
+ case expanded of
Left err -> do
- addGhcCPPError
- loc
- ( hang
- (text "Error evaluating CPP condition:")
- 2
- (text err <+> text "of" $+$ text expanded)
- )
- return 0
- Right tree -> return (eval tree)
- return (toBool v)
+ Lexer.addError err
+ return False
+ Right expanded -> do
+ v <- case Parser.parseExpr expanded of
+ Left err -> do
+ let detail =
+ if str == expanded || expanded == ""
+ then
+ [ text str
+ ]
+ else
+ [ text expanded
+ , text "expanded from:"
+ , text str
+ ]
+ addGhcCPPError
+ loc
+ ( hang
+ (text "Error evaluating CPP condition:")
+ 2
+ ( text err
+ <+> text "of"
+ $+$ vcat detail
+ )
+ )
+ return 0
+ Right tree -> return (eval tree)
+ return (toBool v)
-- ---------------------------------------------------------------------
-expand :: SrcSpan -> MacroDefines -> String -> PP String
+expand :: SrcSpan -> MacroDefines -> String -> PP (Either (MsgEnvelope PsMessage) String)
expand loc s str = do
- toks <- case cppLex False str of
+ case cppLex False str of
Left err -> do
- addGhcCPPError
- loc
- ( hang
- (text "Error evaluating CPP condition:")
- 2
- (text err <+> text "of" $+$ text str)
+ return
+ ( Left $
+ mkGhcCPPError
+ loc
+ ( hang
+ (text "Error evaluating CPP condition:")
+ 2
+ (text err <+> text "of" $+$ text str)
+ )
)
- return []
- Right tks -> return tks
- expandedToks <- expandToks loc maxExpansions s toks
- return $ combineToks $ map t_str expandedToks
+ Right tks -> do
+ expandedToks <- expandToks loc maxExpansions s tks
+ case expandedToks of
+ Left err -> return (Left err)
+ Right toks -> return $ Right $ combineToks $ map t_str toks
maxExpansions :: Int
maxExpansions = 15
-expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PP [Token]
+expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) [Token])
expandToks loc 0 _ ts = do
- addGhcCPPError
- loc
- ( hang
- (text "CPP macro expansion limit hit:")
- 2
- (text (combineToks $ map t_str ts))
- )
- return ts
+ return $
+ Left $
+ mkGhcCPPError
+ loc
+ ( hang
+ (text "CPP macro expansion limit hit:")
+ 2
+ (text (combineToks $ map t_str ts))
+ )
expandToks loc cnt s ts = do
- (!expansionDone, !r) <- doExpandToks loc False s ts
- if expansionDone
- then expandToks loc (cnt - 1) s r
- else return r
-
-doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PP (Bool, [Token])
-doExpandToks _loc ed _ [] = return (ed, [])
+ expansion <- doExpandToks loc False s ts
+ case expansion of
+ Left err -> return (Left err)
+ Right (!expansionDone, !r) ->
+ if expansionDone
+ then expandToks loc (cnt - 1) s r
+ else return (Right r)
+
+doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) (Bool, [Token]))
+doExpandToks _loc ed _ [] = return $ Right (ed, [])
doExpandToks loc ed s (TIdentifierLParen n : ts) =
-- TIdentifierLParen has no meaning here (only in a #define), so
-- restore it to its constituent tokens
@@ -116,30 +145,32 @@ doExpandToks loc _ s (TIdentifier "defined" : ts) = do
case expandedArgs of
(Just [[TIdentifier macro_name]], rest0) ->
case Map.lookup macro_name s of
- Nothing -> return (True, TInteger "0" : rest0)
- Just _ -> return (True, TInteger "1" : rest0)
+ Nothing -> return $ Right (True, TInteger "0" : rest0)
+ Just _ -> return $ Right (True, TInteger "1" : rest0)
(Nothing, TIdentifier macro_name : ts0) ->
case Map.lookup macro_name s of
- Nothing -> return (True, TInteger "0" : ts0)
- Just _ -> return (True, TInteger "1" : ts0)
+ Nothing -> return $ Right (True, TInteger "0" : ts0)
+ Just _ -> return $ Right (True, TInteger "1" : ts0)
(Nothing, _) -> do
- addGhcCPPError
- loc
- ( hang
- (text "CPP defined: expected an identifier, got:")
- 2
- (text (concatMap t_str ts))
- )
- return (False, [])
+ return $
+ Left $
+ mkGhcCPPError
+ loc
+ ( hang
+ (text "CPP defined: expected an identifier, got:")
+ 2
+ (text (concatMap t_str ts))
+ )
(Just args, _) -> do
- addGhcCPPError
- loc
- ( hang
- (text "CPP defined: expected a single arg, got:")
- 2
- (text (intercalate "," (map (concatMap t_str) args)))
- )
- return (False, [])
+ return $
+ Left $
+ mkGhcCPPError
+ loc
+ ( hang
+ (text "CPP defined: expected a single arg, got:")
+ 2
+ (text (intercalate "," (map (concatMap t_str) args)))
+ )
doExpandToks loc ed s (TIdentifier n : ts) = do
(args, rest0) <- getExpandArgs loc ts
let
@@ -152,11 +183,15 @@ doExpandToks loc ed s (TIdentifier n : ts) = do
(ed0, r, rest1) = case m_args of
Nothing -> (True, rhs, ts)
Just _ -> (True, replace_args args m_args rhs, rest0)
- (ed'', rest) <- doExpandToks loc ed' s ts'
- return (ed'', expanded ++ rest)
+ expansion <- doExpandToks loc ed' s ts'
+ case expansion of
+ Left err -> return $ Left err
+ Right (ed'', rest) -> return $ Right (ed'', expanded ++ rest)
doExpandToks loc ed s (t : ts) = do
- (ed', r) <- doExpandToks loc ed s ts
- return (ed', t : r)
+ expansion <- doExpandToks loc ed s ts
+ case expansion of
+ Left err -> return (Left err)
+ Right (ed', r) -> return $ Right (ed', t : r)
{-
Note: ['defined' unary operator]
=====================================
compiler/GHC/Parser/PreProcess/State.hs
=====================================
@@ -32,6 +32,7 @@ module GHC.Parser.PreProcess.State (
ghcCppEnabled,
setInLinePragma,
getInLinePragma,
+ mkGhcCPPError,
addGhcCPPError,
) where
@@ -71,7 +72,6 @@ initPpState =
, pp_continuation = []
, pp_defines = Map.empty
, pp_scope = (PpScope True PpNoGroup) :| []
- , pp_alr_state = Nothing
, pp_in_line_pragma = False
}
@@ -81,7 +81,6 @@ data PpState = PpState
, pp_continuation :: ![Located Lexer.Token]
, pp_defines :: !MacroDefines
, pp_scope :: !(NonEmpty PpScope)
- , pp_alr_state :: Maybe Lexer.PSavedAlrState
, pp_in_line_pragma :: !Bool
}
@@ -416,6 +415,8 @@ insertMacroDef (MacroName name args) def md =
-- ---------------------------------------------------------------------
+mkGhcCPPError :: SrcSpan -> SDoc -> MsgEnvelope PsMessage
+mkGhcCPPError loc err = mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp err
+
addGhcCPPError :: SrcSpan -> SDoc -> P p ()
-addGhcCPPError loc err =
- Lexer.addError $ mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp err
+addGhcCPPError loc err = Lexer.addError $ mkGhcCPPError loc err
=====================================
testsuite/tests/ghc-cpp/GhcCpp02.stderr
=====================================
@@ -6,28 +6,15 @@ GhcCpp02.hs:12:1: error: [GHC-93098]
Error evaluating CPP condition:
Parse error at line 1, column 23 of
2 + NONEXISTENT_MACRO ( 4 )
-
-GhcCpp02.hs:17:1: error: [GHC-93098]
- Error evaluating CPP condition:
- Parse error at line 1, column 4 of
- FOO( 3 )
+ expanded from:
+ EXISTENT_MACRO( 4 )
GhcCpp02.hs:17:1: error: [GHC-93098]
CPP macro expansion limit hit: FOO( 3 )
-GhcCpp02.hs:21:1: error: [GHC-93098]
- Error evaluating CPP condition:
- Parse error at line 1, column 0 of
-
-
GhcCpp02.hs:21:1: error: [GHC-93098]
CPP defined: expected an identifier, got: 34
-GhcCpp02.hs:24:1: error: [GHC-93098]
- Error evaluating CPP condition:
- Parse error at line 1, column 0 of
-
-
GhcCpp02.hs:24:1: error: [GHC-93098]
CPP defined: expected a single arg, got: A,B
=====================================
utils/check-cpp/PreProcess.hs
=====================================
@@ -329,15 +329,8 @@ processCpp loc s = do
acceptStateChange :: AcceptingResult -> PP ()
acceptStateChange ArNoChange = return ()
acceptStateChange ArNowIgnoring = do
- -- alr <- Lexer.getAlrState
- -- s <- getPpState
- -- let s = trace ("acceptStateChange:ArNowIgnoring") s'
- -- setPpState (s { pp_alr_state = Just alr})
Lexer.startSkipping
acceptStateChange ArNowAccepting = do
- -- s <- getPpState
- -- let s = trace ("acceptStateChange:ArNowAccepting") s'
- -- mapM_ Lexer.setAlrState (pp_alr_state s)
_ <- Lexer.stopSkipping
return ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9f4b5aabeeeabc3134e5464f8ecb70…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9f4b5aabeeeabc3134e5464f8ecb70…
You're receiving this email because of your account on gitlab.haskell.org.
1
0