[Git][ghc/ghc][wip/fix-26636] 4 commits: compiler: remove unused CPP code in foreign stub
by recursion-ninja (＠recursion-ninja) 12 Dec '25
by recursion-ninja (＠recursion-ninja) 12 Dec '25
12 Dec '25
recursion-ninja pushed to branch wip/fix-26636 at Glasgow Haskell Compiler / GHC
Commits:
d99f8326 by Cheng Shao at 2025-12-11T19:14:18-05:00
compiler: remove unused CPP code in foreign stub
This patch removes unused CPP code in the generated foreign stub:
- `#define IN_STG_CODE 0` is not needed, since `Rts.h` already
includes this definition
- The `if defined(__cplusplus)` code paths are not needed in the `.c`
file, since we don't generate C++ stubs and don't include C++
headers in our stubs. But it still needs to be present in the `.h`
header since it might be later included into C++ source files.
- - - - -
46c9746f by Cheng Shao at 2025-12-11T19:14:57-05:00
configure: bump LlvmMaxVersion to 22
This commit bumps LlvmMaxVersion to 22; 21.x releases have been
available since Aug 26th, 2025 and there's no regressions with 21.x so
far. This bump is also required for updating fedora image to 43.
- - - - -
d29d8790 by Recursion Ninja at 2025-12-12T10:05:43-05:00
Removing the 'Data' instance for 'InstEnv'.
The 'Data' instance is blocking work on Trees that Grow, and the
'Data' instance seem to have been added without a clear purpose.
- - - - -
ed0e7096 by Recursion Ninja at 2025-12-12T10:05:54-05:00
'Decouple Language.Haskell.Syntax.Decls' from 'GHC.Unit.Module.Warnings'
- - - - -
23 changed files:
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Warnings.hs
- compiler/GHC/Parser.y
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Types/DefaultEnv.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Unit/Module/Warnings.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- configure.ac
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
Changes:
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -79,6 +79,7 @@ import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Parser.Annotation
import GHC.Hs.Doc
+import GHC.Hs.Extension (GhcPass)
import GHC.Unit.Module.ModIface (IfaceExport)
import GHC.Unit.Module.Warnings
@@ -263,7 +264,7 @@ ghcPrimNames
]
-- See Note [GHC.Prim Deprecations]
-ghcPrimWarns :: Warnings a
+ghcPrimWarns :: Warnings (GhcPass p)
ghcPrimWarns = WarnSome
-- declaration warnings
(map mk_decl_dep primOpDeprecations)
=====================================
compiler/GHC/Core/InstEnv.hs
=====================================
@@ -7,7 +7,7 @@
The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv.
-}
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
module GHC.Core.InstEnv (
DFunId, InstMatch, ClsInstLookupResult,
@@ -55,7 +55,6 @@ import GHC.Types.Name.Set
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Generics (Generic)
-import Data.Data ( Data )
import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
import qualified Data.List.NonEmpty as NE
import Data.Maybe ( isJust )
@@ -114,7 +113,6 @@ data ClsInst
-- See Note [Implementation of deprecated instances]
-- in GHC.Tc.Solver.Dict
}
- deriving Data
-- | A fuzzy comparison function for class instances, intended for sorting
-- instances before displaying them to the user.
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -329,15 +329,8 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
stub_c_file_exists
<- outputForeignStubs_help stub_c stub_c_output_w
- ("#define IN_STG_CODE 0\n" ++
- "#include <Rts.h>\n" ++
- rts_includes ++
- ffi_includes ++
- cplusplus_hdr)
- cplusplus_ftr
- -- We're adding the default hc_header to the stub file, but this
- -- isn't really HC code, so we need to define IN_STG_CODE==0 to
- -- avoid the register variables etc. being enabled.
+ (rts_includes ++
+ ffi_includes) ""
return (stub_h_file_exists, if stub_c_file_exists
then Just stub_c
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1391,7 +1391,6 @@ type instance XXWarnDecls (GhcPass _) = DataConCantHappen
type instance XWarning (GhcPass _) = (NamespaceSpecifier, (EpToken "[", EpToken "]"))
type instance XXWarnDecl (GhcPass _) = DataConCantHappen
-
instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
ppr (Warnings ext decls)
@@ -1411,7 +1410,7 @@ instance OutputableBndrId p
<+> ppr txt
where
ppr_category = case txt of
- WarningTxt (Just cat) _ _ -> ppr cat
+ WarningTxt _ (Just cat) _ -> ppr cat
_ -> empty
{-
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Hs.ImpExp
import GHC.Parser.Annotation
import GHC.Types.Name.Reader (WithUserRdr(..))
import GHC.Data.BooleanFormula (BooleanFormula(..))
+import Language.Haskell.Syntax.Decls
import Language.Haskell.Syntax.Extension (Anno)
-- ---------------------------------------------------------------------
@@ -276,6 +277,14 @@ deriving instance Data (WarnDecl GhcPs)
deriving instance Data (WarnDecl GhcRn)
deriving instance Data (WarnDecl GhcTc)
+deriving instance Data (WarningTxt GhcPs)
+deriving instance Data (WarningTxt GhcRn)
+deriving instance Data (WarningTxt GhcTc)
+
+deriving instance Data (InWarningCategory GhcPs)
+deriving instance Data (InWarningCategory GhcRn)
+deriving instance Data (InWarningCategory GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (AnnDecl p)
deriving instance Data (AnnProvenance GhcPs)
deriving instance Data (AnnProvenance GhcRn)
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -424,8 +424,8 @@ data IfaceWarnings
[(IfExtName, IfaceWarningTxt)]
data IfaceWarningTxt
- = IfWarningTxt (Maybe WarningCategory) SourceText [(IfaceStringLiteral, [IfExtName])]
- | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])]
+ = IfWarningTxt SourceText (Maybe WarningCategory) [(IfaceStringLiteral, [IfExtName])]
+ | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])]
data IfaceStringLiteral
= IfStringLiteral SourceText FastString
@@ -664,7 +664,7 @@ fromIfaceWarnings = \case
fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt = \case
- IfWarningTxt mb_cat src strs -> WarningTxt (noLocA . fromWarningCategory <$> mb_cat) src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+ IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
=====================================
compiler/GHC/Iface/Warnings.hs
=====================================
@@ -23,7 +23,7 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
-toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)
toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2053,12 +2053,12 @@ maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
{% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
(AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) }
| '{-# WARNING' warning_category strings '#-}'
- {% fmap Just $ amsr (sLL $1 $> $ WarningTxt $2 (getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))
+ {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))
(AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)}
| {- empty -} { Nothing }
-warning_category :: { Maybe (LocatedE InWarningCategory) }
- : 'in' STRING { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2)
+warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) }
+ : 'in' STRING { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1, getSTRINGs $2)
(reLoc $ sL1 $2 $ mkWarningCategory (getSTRING $2))) }
| {- empty -} { Nothing }
@@ -2083,7 +2083,7 @@ warning :: { OrdList (LWarnDecl GhcPs) }
: warning_category namespace_spec namelist strings
{% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4)
(Warning (unLoc $2, fst $ unLoc $4) (unLoc $3)
- (WarningTxt $1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $4))) }
+ (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) }
namespace_spec :: { Located NamespaceSpecifier }
: 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) }
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -320,12 +320,16 @@ rnSrcWarnDecls bndr_set decls'
rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
-rnWarningTxt (WarningTxt mb_cat st wst) = do
- forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) ->
- unless (validWarningCategory cat) $
- addErrAt (locA loc) (TcRnInvalidWarningCategory cat)
+rnWarningTxt (WarningTxt st mb_cat wst) = do
+ mb_cat' <- case mb_cat of
+ Nothing -> pure Nothing
+ Just (L x (InWarningCategory y (L loc cat))) -> do
+ unless (validWarningCategory cat) $
+ addErrAt (locA loc) (TcRnInvalidWarningCategory cat)
+ pure . Just $ L x (InWarningCategory y (L loc cat))
wst' <- traverse (traverse rnHsDoc) wst
- pure (WarningTxt mb_cat st wst')
+ pure (WarningTxt st mb_cat' wst')
+
rnWarningTxt (DeprecatedTxt st wst) = do
wst' <- traverse (traverse rnHsDoc) wst
pure (DeprecatedTxt st wst')
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -69,7 +69,6 @@ import GHC.Data.Bag ( mapBagM, headMaybe )
import Control.Monad
import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
import GHC.Unit.Module
-import GHC.Unit.Module.Warnings ( WarningTxt(..) )
import GHC.Iface.Load
import qualified GHC.LanguageExtensions as LangExt
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -57,7 +57,6 @@ import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
-import GHC.Unit.Module.Warnings
import GHC.Builtin.Names
import GHC.Utils.Error
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -52,7 +52,6 @@ import GHC.Core.Type
import GHC.Hs
import GHC.Driver.Session
import GHC.Unit.Module (getModule)
-import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface (mi_fix)
import GHC.Iface.Load (loadInterfaceForName)
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1841,7 +1841,7 @@ instance Diagnostic TcRnMessage where
nest 2 (vcat (map (ppr . hsDocString . unLoc) msg)) ]
where
(extra, msg) = case txt of
- WarningTxt _ _ msg -> ("", msg)
+ WarningTxt _ _ msg -> ("", msg)
DeprecatedTxt _ msg -> (" is deprecated", msg)
TcRnRedundantSourceImport mod_name
-> mkSimpleDecorated $
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -221,7 +221,6 @@ import GHC.Types.DefaultEnv (ClassDefaults)
import GHC.Unit.Types (Module)
import GHC.Unit.State (UnitState)
-import GHC.Unit.Module.Warnings (WarningCategory, WarningTxt)
import GHC.Unit.Module.ModIface (ModIface)
import GHC.Utils.Outputable
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -67,7 +67,6 @@ import GHC.Core.PatSyn
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Unit.Module
-import GHC.Unit.Module.Warnings
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -91,7 +91,6 @@ import GHC.Utils.Unique (sameUnique)
import GHC.Unit.State
import GHC.Unit.External
-import GHC.Unit.Module.Warnings
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
=====================================
compiler/GHC/Types/DefaultEnv.hs
=====================================
@@ -21,13 +21,12 @@ where
import GHC.Core.Class (Class (className))
import GHC.Prelude
-import GHC.Hs.Extension (GhcRn)
+import GHC.Hs
import GHC.Tc.Utils.TcType (Type)
import GHC.Types.Name (Name, nameUnique, stableNameCmp)
import GHC.Types.Name.Env
import GHC.Types.Unique.FM (lookupUFM_Directly)
import GHC.Types.SrcLoc (SrcSpan)
-import GHC.Unit.Module.Warnings (WarningTxt)
import GHC.Unit.Types (Module)
import GHC.Utils.Outputable
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -768,6 +768,7 @@ type family GhcDiagnosticCode c = n | n -> c where
-- TcRnPragmaWarning
GhcDiagnosticCode "WarningTxt" = 63394
GhcDiagnosticCode "DeprecatedTxt" = 68441
+ GhcDiagnosticCode "XWarningTxt" = 68077
-- TcRnRunSliceFailure/ConversionFail
GhcDiagnosticCode "IllegalOccName" = 55017
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -11,6 +11,9 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
+-- Eq instances for WarningTxt, InWarningCategory
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
-- | Warnings for a module
module GHC.Unit.Module.Warnings
( WarningCategory(..)
@@ -48,7 +51,7 @@ where
import GHC.Prelude
-import GHC.Data.FastString (FastString, mkFastString, unpackFS)
+import GHC.Data.FastString (mkFastString, unpackFS)
import GHC.Types.SourceText
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Env
@@ -65,77 +68,15 @@ import GHC.Utils.Binary
import GHC.Unicode
import Language.Haskell.Syntax.Extension
+import Language.Haskell.Syntax.Decls
-import Data.Data
import Data.List (isPrefixOf)
-import GHC.Generics ( Generic )
-import Control.DeepSeq
-
-
-{-
-Note [Warning categories]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-See GHC Proposal 541 for the design of the warning categories feature:
-https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst
-
-A WARNING pragma may be annotated with a category such as "x-partial" written
-after the 'in' keyword, like this:
-
- {-# WARNING in "x-partial" head "This function is partial..." #-}
-
-This is represented by the 'Maybe (Located WarningCategory)' field in
-'WarningTxt'. The parser will accept an arbitrary string as the category name,
-then the renamer (in 'rnWarningTxt') will check it contains only valid
-characters, so we can generate a nicer error message than a parse error.
-
-The corresponding warnings can then be controlled with the -Wx-partial,
--Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags. Such a flag is
-distinguished from an 'unrecognisedWarning' by the flag parser testing
-'validWarningCategory'. The 'x-' prefix means we can still usually report an
-unrecognised warning where the user has made a mistake.
-
-A DEPRECATED pragma may not have a user-defined category, and is always treated
-as belonging to the special category 'deprecations'. Similarly, a WARNING
-pragma without a category belongs to the 'deprecations' category.
-Thus the '-Wdeprecations' flag will enable all of the following:
-
- {-# WARNING in "deprecations" foo "This function is deprecated..." #-}
- {-# WARNING foo "This function is deprecated..." #-}
- {-# DEPRECATED foo "This function is deprecated..." #-}
-
-The '-Wwarnings-deprecations' flag is supported for backwards compatibility
-purposes as being equivalent to '-Wdeprecations'.
-
-The '-Wextended-warnings' warning group collects together all warnings with
-user-defined categories, so they can be enabled or disabled
-collectively. Moreover they are treated as being part of other warning groups
-such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings').
-
-'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal
-warning categories, just as they do for the finite enumeration of 'WarningFlag's
-built in to GHC. These are represented as 'WarningCategorySet's to allow for
-the possibility of them being infinite.
-
--}
-data InWarningCategory
- = InWarningCategory
- { iwc_in :: !(EpToken "in"),
- iwc_st :: !SourceText,
- iwc_wc :: (LocatedE WarningCategory)
- } deriving Data
-fromWarningCategory :: WarningCategory -> InWarningCategory
-fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc)
-
-
--- See Note [Warning categories]
-newtype WarningCategory = WarningCategory FastString
- deriving stock Data
- deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData)
-
-mkWarningCategory :: FastString -> WarningCategory
-mkWarningCategory = WarningCategory
+fromWarningCategory ::
+ HasAnnotation (Anno WarningCategory) =>
+ WarningCategory -> InWarningCategory (GhcPass p)
+fromWarningCategory wc = InWarningCategory (noAnn, NoSourceText) (noLocA wc)
-- | The @deprecations@ category is used for all DEPRECATED pragmas and for
-- WARNING pragmas that do not specify a category.
@@ -153,7 +94,6 @@ validWarningCategory cat@(WarningCategory c) =
s = unpackFS c
is_allowed c = isAlphaNum c || c == '\'' || c == '-'
-
-- | A finite or infinite set of warning categories.
--
-- Unlike 'WarningFlag', there are (in principle) infinitely many warning
@@ -198,66 +138,74 @@ deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCateg
type LWarningTxt pass = XRec pass (WarningTxt pass)
--- | Warning Text
---
--- reason/explanation from a WARNING or DEPRECATED pragma
-data WarningTxt pass
- = WarningTxt
- (Maybe (LocatedE InWarningCategory))
- -- ^ Warning category attached to this WARNING pragma, if any;
- -- see Note [Warning categories]
- SourceText
- [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
- | DeprecatedTxt
- SourceText
- [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
- deriving Generic
-
-- | To which warning category does this WARNING or DEPRECATED pragma belong?
-- See Note [Warning categories].
-warningTxtCategory :: WarningTxt pass -> WarningCategory
-warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _ _) = cat
+warningTxtCategory :: WarningTxt (GhcPass p) -> WarningCategory
+warningTxtCategory (WarningTxt _ (Just (L _ (InWarningCategory _ (L _ cat)))) _) = cat
warningTxtCategory _ = defaultWarningCategory
+
-- | The message that the WarningTxt was specified to output
-warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)]
-warningTxtMessage (WarningTxt _ _ m) = m
+warningTxtMessage :: WarningTxt (GhcPass p) -> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass p))]
+warningTxtMessage (WarningTxt _ _ m) = m
warningTxtMessage (DeprecatedTxt _ m) = m
-- | True if the 2 WarningTxts have the same category and messages
-warningTxtSame :: WarningTxt p1 -> WarningTxt p2 -> Bool
+warningTxtSame :: WarningTxt (GhcPass p) -> WarningTxt (GhcPass p) -> Bool
warningTxtSame w1 w2
= warningTxtCategory w1 == warningTxtCategory w2
&& literal_message w1 == literal_message w2
&& same_type
where
- literal_message :: WarningTxt p -> [StringLiteral]
+ literal_message :: WarningTxt (GhcPass p) -> [StringLiteral]
literal_message = map (hsDocString . unLoc) . warningTxtMessage
same_type | DeprecatedTxt {} <- w1, DeprecatedTxt {} <- w2 = True
- | WarningTxt {} <- w1, WarningTxt {} <- w2 = True
+ | WarningTxt {} <- w1, WarningTxt {} <- w2 = True
| otherwise = False
-deriving instance Eq InWarningCategory
+instance Outputable (InWarningCategory (GhcPass pass)) where
+ ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt)
-deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass)
-deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)
+type instance XDeprecatedTxt (GhcPass _) = SourceText
+type instance XWarningTxt (GhcPass _) = SourceText
+type instance XXWarningTxt (GhcPass _) = DataConCantHappen
+type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText)
+type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
+type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation
+type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation
+type instance Anno (WarningCategory) = EpaLocation
type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP
-instance Outputable InWarningCategory where
- ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt)
+deriving stock instance Eq (WarningTxt GhcPs)
+deriving stock instance Eq (WarningTxt GhcRn)
+deriving stock instance Eq (WarningTxt GhcTc)
+
+deriving stock instance Eq (InWarningCategory GhcPs)
+deriving stock instance Eq (InWarningCategory GhcRn)
+deriving stock instance Eq (InWarningCategory GhcTc)
+
+-- TODO: Move to respecitive type-class definition modules after removing
+-- the Language.Haskell.Syntax.Decls module's dependency on GHC.Hs.Doc.
+-- Subsequently, create a Language.Haskell.Syntax.Decls.Warnings sub-module
+-- with the "warning declaration" types and have Language.Haskell.Syntax.Decls
+-- re-export Language.Haskell.Syntax.Decls.Warnings. This will prevent cyclic
+-- import, but it will only work once GHC.Hs.Doc is no longer a GHC dependency.
+deriving instance Binary WarningCategory
+deriving instance Outputable WarningCategory
-instance Outputable (WarningTxt pass) where
- ppr (WarningTxt mcat lsrc ws)
+deriving instance Uniquable WarningCategory
+
+instance Outputable (WarningTxt (GhcPass pass)) where
+ ppr (WarningTxt lsrc mcat ws)
= case lsrc of
NoSourceText -> pp_ws ws
SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
where
ctg_doc = maybe empty (\ctg -> ppr ctg) mcat
-
- ppr (DeprecatedTxt lsrc ds)
+ ppr (DeprecatedTxt lsrc ds)
= case lsrc of
NoSourceText -> pp_ws ds
SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
@@ -270,7 +218,7 @@ pp_ws ws
<+> text "]"
-pprWarningTxtForMsg :: WarningTxt p -> SDoc
+pprWarningTxtForMsg :: WarningTxt (GhcPass pass) -> SDoc
pprWarningTxtForMsg (WarningTxt _ _ ws)
= doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws))
pprWarningTxtForMsg (DeprecatedTxt _ ds)
@@ -316,8 +264,6 @@ type DeclWarnOccNames pass = [(OccName, WarningTxt pass)]
-- | Names that are deprecated as exports
type ExportWarnNames pass = [(Name, WarningTxt pass)]
-deriving instance Eq (IdP pass) => Eq (Warnings pass)
-
emptyWarn :: Warnings p
emptyWarn = WarnSome [] []
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -1,10 +1,11 @@
-
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@@ -83,7 +84,18 @@ module Language.Haskell.Syntax.Decls (
FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,
-- * Grouping
- HsGroup(..)
+ HsGroup(..),
+
+ -- * Warnings
+ WarningTxt(..),
+ WarningCategory(..),
+ mkWarningCategory,
+ InWarningCategory(..),
+ -- ** Extension
+ XDeprecatedTxt,
+ XWarningTxt,
+ XXWarningTxt,
+ XInWarningCategory,
) where
-- friends:
@@ -101,12 +113,14 @@ import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation
,TyConFlavour(..), TypeOrData(..), NewOrData(..))
import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec)
-import GHC.Unit.Module.Warnings (WarningTxt)
-
+import GHC.Data.FastString (FastString)
import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST
+import GHC.Hs.Doc (WithHsDocIdentifiers)
+import GHC.Types.SourceText (StringLiteral)
-import Control.Monad
+import Control.DeepSeq
import Control.Exception (assert)
+import Control.Monad
import Data.Data hiding (TyCon, Fixity, Infix)
import Data.Maybe
import Data.String
@@ -117,6 +131,8 @@ import Prelude (Show)
import Data.Foldable
import Data.Traversable
import Data.List.NonEmpty (NonEmpty (..))
+import GHC.Generics ( Generic )
+
{-
************************************************************************
@@ -1589,3 +1605,85 @@ data RoleAnnotDecl pass
(LIdP pass) -- type constructor
[XRec pass (Maybe Role)] -- optional annotations
| XRoleAnnotDecl !(XXRoleAnnotDecl pass)
+
+{-
+************************************************************************
+* *
+\subsection[WarnAnnot]{Warning annotations}
+* *
+************************************************************************
+-}
+
+-- | Warning Text
+--
+-- reason/explanation from a WARNING or DEPRECATED pragma
+data WarningTxt pass
+ = DeprecatedTxt
+ (XDeprecatedTxt pass)
+ [XRec pass (WithHsDocIdentifiers StringLiteral pass)]
+ | WarningTxt
+ (XWarningTxt pass)
+ (Maybe (XRec pass (InWarningCategory pass)))
+ -- ^ Warning category attached to this WARNING pragma, if any;
+ -- see Note [Warning categories]
+ [XRec pass (WithHsDocIdentifiers StringLiteral pass)]
+ | XWarningTxt !(XXWarningTxt pass)
+ deriving Generic
+
+{-
+Note [Warning categories]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+See GHC Proposal 541 for the design of the warning categories feature:
+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst
+
+A WARNING pragma may be annotated with a category such as "x-partial" written
+after the 'in' keyword, like this:
+
+ {-# WARNING in "x-partial" head "This function is partial..." #-}
+
+This is represented by the 'Maybe (Located WarningCategory)' field in
+'WarningTxt'. The parser will accept an arbitrary string as the category name,
+then the renamer (in 'rnWarningTxt') will check it contains only valid
+characters, so we can generate a nicer error message than a parse error.
+
+The corresponding warnings can then be controlled with the -Wx-partial,
+-Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags. Such a flag is
+distinguished from an 'unrecognisedWarning' by the flag parser testing
+'validWarningCategory'. The 'x-' prefix means we can still usually report an
+unrecognised warning where the user has made a mistake.
+
+A DEPRECATED pragma may not have a user-defined category, and is always treated
+as belonging to the special category 'deprecations'. Similarly, a WARNING
+pragma without a category belongs to the 'deprecations' category.
+Thus the '-Wdeprecations' flag will enable all of the following:
+
+ {-# WARNING in "deprecations" foo "This function is deprecated..." #-}
+ {-# WARNING foo "This function is deprecated..." #-}
+ {-# DEPRECATED foo "This function is deprecated..." #-}
+The '-Wwarnings-deprecations' flag is supported for backwards compatibility
+purposes as being equivalent to '-Wdeprecations'.
+
+The '-Wextended-warnings' warning group collects together all warnings with
+user-defined categories, so they can be enabled or disabled
+collectively. Moreover they are treated as being part of other warning groups
+such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings').
+
+'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal
+warning categories, just as they do for the finite enumeration of 'WarningFlag's
+built in to GHC. These are represented as 'WarningCategorySet's to allow for
+the possibility of them being infinite.
+
+-}
+data InWarningCategory pass
+ = InWarningCategory
+ { iwc_st :: (XInWarningCategory pass),
+ iwc_wc :: (XRec pass WarningCategory)
+ }
+ | XInWarningCategory !(XXInWarningCategory pass)
+
+newtype WarningCategory = WarningCategory FastString
+ deriving stock (Data)
+ deriving newtype (Eq, Show, NFData)
+
+mkWarningCategory :: FastString -> WarningCategory
+mkWarningCategory = WarningCategory
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -421,6 +421,17 @@ type family XXWarnDecls x
type family XWarning x
type family XXWarnDecl x
+-- -------------------------------------
+-- WarningTxt type families
+type family XDeprecatedTxt x
+type family XWarningTxt x
+type family XXWarningTxt x
+
+-- -------------------------------------
+-- InWarningCategory type families
+type family XInWarningCategory x
+type family XXInWarningCategory x
+
-- -------------------------------------
-- AnnDecl type families
type family XHsAnnotation x
=====================================
configure.ac
=====================================
@@ -526,7 +526,7 @@ AC_SUBST(InstallNameToolCmd)
# versions of LLVM simultaneously, but that stopped working around
# 3.5/3.6 release of LLVM.
LlvmMinVersion=13 # inclusive
-LlvmMaxVersion=21 # not inclusive
+LlvmMaxVersion=22 # not inclusive
AC_SUBST([LlvmMinVersion])
AC_SUBST([LlvmMaxVersion])
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -354,7 +354,7 @@ parseWarning
-> IfM m (Doc Name)
parseWarning parserOpts sDocContext w = case w of
IfDeprecatedTxt _ msg -> format "Deprecated: " (map dstToDoc msg)
- IfWarningTxt _ _ msg -> format "Warning: " (map dstToDoc msg)
+ IfWarningTxt _ _ msg -> format "Warning: " (map dstToDoc msg)
where
dstToDoc :: (IfaceStringLiteral, [Name]) -> HsDoc GhcRn
dstToDoc ((IfStringLiteral _ fs), ids) = WithHsDocIdentifiers (fsToDoc fs) (map noLoc ids)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf3c9537d6c82e9271ad6df2b10cad…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf3c9537d6c82e9271ad6df2b10cad…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] ci: use treeless fetch for perf notes
by Marge Bot (＠marge-bot) 12 Dec '25
by Marge Bot (＠marge-bot) 12 Dec '25
12 Dec '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
ed55a3d7 by Cheng Shao at 2025-12-12T09:48:45-05:00
ci: use treeless fetch for perf notes
This patch improves the ci logic for fetching perf notes by using
treeless fetch
(https://github.blog/open-source/git/get-up-to-speed-with-partial-clone-and-…)
to avoid downloading all blobs of the perf notes repo at once, and
only fetch the actually required blobs on-demand when needed. This
makes the initial `test-metrics.sh pull` operation much faster, and
also more robust, since we are seeing an increasing rate of 504 errors
in CI when fetching all perf notes at once, which is a major source of
CI flakiness at this point.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
1 changed file:
- .gitlab/test-metrics.sh
Changes:
=====================================
.gitlab/test-metrics.sh
=====================================
@@ -17,12 +17,14 @@ fail() {
function pull() {
local ref="refs/notes/$REF"
- # 2023-10-04: `git fetch` started failing, first on Darwin in CI and then on
- # Linux locally, both using git version 2.40.1. See #24055. One workaround is
- # to set a larger http.postBuffer, although this is definitely a workaround.
- # The default should work just fine. The error could be in git, GitLab, or
- # perhaps the networking tube (including all proxies etc) between the two.
- run git -c http.postBuffer=2097152 fetch -f "$NOTES_ORIGIN" "$ref:$ref"
+
+ # Fetch performance notes from a dedicated promisor remote using a
+ # treeless filter, so that individual note blobs are fetched lazily
+ # as needed.
+ git remote add perf-notes "$NOTES_ORIGIN" || true
+ git config fetch.recurseSubmodules false
+ git config remote.perf-notes.partialclonefilter tree:0
+ run git fetch --force perf-notes "$ref:$ref"
echo "perf notes ref $ref is $(git rev-parse $ref)"
}
@@ -81,4 +83,3 @@ case $1 in
pull) pull ;;
*) fail "Invalid mode $1" ;;
esac
-
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed55a3d7950a1f24e8515e9fad0d7e6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed55a3d7950a1f24e8515e9fad0d7e6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/andreask/hadrian_typeable
by Andreas Klebinger (＠AndreasK) 12 Dec '25
by Andreas Klebinger (＠AndreasK) 12 Dec '25
12 Dec '25
Andreas Klebinger pushed new branch wip/andreask/hadrian_typeable at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/hadrian_typeable
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/mod-origin-hidden-reexports-message-fix] 8 commits: Narrow before optimising MUL/DIV/REM into shifts
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
12 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/mod-origin-hidden-reexports-message-fix at Glasgow Haskell Compiler / GHC
Commits:
fe2b79f4 by Recursion Ninja at 2025-12-10T08:34:18-05:00
Narrow before optimising MUL/DIV/REM into shifts
The MUL/DIV/REM operations can be optimised into shifts when one of the
operands is a constant power of 2. However, as literals in Cmm are
stored as 'Integer', for this to be correct we first need to narrow the
literal to the appropriate width before checking whether the literal is
a power of 2.
Fixes #25664
- - - - -
06c2349c by Recursion Ninja at 2025-12-10T08:34:58-05:00
Decouple 'Language.Haskell.Syntax.Type' from 'GHC.Utils.Panic'
- Remove the *original* defintion of 'hsQTvExplicit' defined within 'Language.Haskell.Syntax.Type'
- Redefine 'hsQTvExplicit' as 'hsq_explicit' specialized to 'GhcPass' exported by 'GHC.Utils.Panic'
- Define 'hsQTvExplicitBinders' as 'hsq_explicit' specialized to 'DocNameI' exported by 'Haddock.GhcUtils'.
- Replace all call sites of the original 'hsQTvExplicit' definition with either:
1. 'hsQTvExplicit' updated definition
2. 'hsQTvExplicitBinders'
All call sites never entered the 'XLHsQTyVars' constructor branch, but a call to 'panic' existed on this code path because the type system was not strong enought to guarantee that the 'XLHsQTyVars' construction was impossible.
These two specialized functions provide the type system with enough information to make that guarantee, and hence the dependancy on 'panic' can be removed.
- - - - -
ac0815d5 by sheaf at 2025-12-10T23:39:57-05:00
Quantify arg before mult in function arrows
As noted in #23764, we expect quantification order to be left-to-right,
so that in a type such as
a %m -> b
the inferred quantification order should be [a, m, b] and not [m, a, b].
This was addressed in commit d31fbf6c, but that commit failed to update
some other functions such as GHC.Core.TyCo.FVs.tyCoFVsOfType.
This affects Haddock, as whether we print an explicit forall or not
depends on whether the inferred quantification order matches the actual
quantification order.
- - - - -
2caf796e by sheaf at 2025-12-10T23:39:57-05:00
Haddock: improvements to ty-var quantification
This commit makes several improvements to how Haddock deals with the
quantification of type variables:
1. In pattern synonyms, Haddock used to jumble up universal and
existential quantification. That is now fixed, fixing #26252.
Tested in the 'PatternSyns2' haddock-html test.
2. The logic for computing whether to use an explicit kind annotation
for a type variable quantified in a forall was not even wrong.
This commit improves the heuristic, but it will always remain an
imperfect heuristic (lest we actually run kind inference again).
In the future (#26271), we hope to avoid reliance on this heuristic.
- - - - -
b14bdd59 by Teo Camarasu at 2025-12-10T23:40:38-05:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
d99f8326 by Cheng Shao at 2025-12-11T19:14:18-05:00
compiler: remove unused CPP code in foreign stub
This patch removes unused CPP code in the generated foreign stub:
- `#define IN_STG_CODE 0` is not needed, since `Rts.h` already
includes this definition
- The `if defined(__cplusplus)` code paths are not needed in the `.c`
file, since we don't generate C++ stubs and don't include C++
headers in our stubs. But it still needs to be present in the `.h`
header since it might be later included into C++ source files.
- - - - -
46c9746f by Cheng Shao at 2025-12-11T19:14:57-05:00
configure: bump LlvmMaxVersion to 22
This commit bumps LlvmMaxVersion to 22; 21.x releases have been
available since Aug 26th, 2025 and there's no regressions with 21.x so
far. This bump is also required for updating fedora image to 43.
- - - - -
ad2a0c1e by Torsten Schmits at 2025-12-12T13:04:33+01:00
Use the correct field of ModOrigin when formatting error message listing hidden reexports
- - - - -
29 changed files:
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Unit/State.hs
- compiler/Language/Haskell/Syntax/Type.hs
- configure.ac
- libraries/base/src/GHC/Num.hs
- + testsuite/tests/cmm/opt/T25664.hs
- + testsuite/tests/cmm/opt/T25664.stdout
- testsuite/tests/cmm/opt/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- 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/html-test/ref/Bug1050.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/PatternSyns.html
- + utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/TypeOperators.html
- + utils/haddock/html-test/src/PatternSyns2.hs
- utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
Changes:
=====================================
compiler/GHC/Cmm/Opt.hs
=====================================
@@ -395,26 +395,39 @@ cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt 1 rep))]
one = CmmLit (CmmInt 1 (wordWidth platform))
-- Now look for multiplication/division by powers of 2 (integers).
-
-cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]
+--
+-- Naively this is as simple a matter as left/right bit shifts,
+-- but the Cmm representation if integral values quickly complicated the matter.
+--
+-- We must carefully narrow the value to be within the range of values for the
+-- type's logical bit-width. However, Cmm only represents values as *signed*
+-- integers internally yet the logical type may be unsigned. If we are dealing
+-- with a negative integer type at width @_w@, the only negative number that
+-- wraps around to be a positive power of 2 after calling narrowU is -2^(_w - 1)
+-- which wraps round to 2^(_w - 1), and multiplying by -2^(_w - 1) is indeed
+-- the same as a left shift by (w - 1), so this is OK.
+--
+-- ToDo: See #25664 (comment 605821) describing a change to the Cmm literal representation.
+-- When/If this is completed, this code must be refactored to account for the explicit width sizes.
+cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _w))]
= case mop of
MO_Mul rep
- | Just p <- exactLog2 n ->
+ | Just p <- exactLog2 (narrowU rep n) ->
Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)])
MO_U_Quot rep
- | Just p <- exactLog2 n ->
+ | Just p <- exactLog2 (narrowU rep n) ->
Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)])
MO_U_Rem rep
- | Just _ <- exactLog2 n ->
+ | Just _ <- exactLog2 (narrowU rep n) ->
Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
MO_S_Quot rep
- | Just p <- exactLog2 n,
+ | Just p <- exactLog2 (narrowS rep n),
CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require
-- it is a reg. FIXME: remove this restriction.
Just $! (cmmMachOpFold platform (MO_S_Shr rep)
[signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)])
MO_S_Rem rep
- | Just p <- exactLog2 n,
+ | Just p <- exactLog2 (narrowS rep n),
CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require
-- it is a reg. FIXME: remove this restriction.
-- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -635,7 +635,9 @@ tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_v
-- See Note [Free vars and synonyms]
tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc
tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc
-tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc
+tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc =
+ -- As per #23764, if we have 'a %m -> b', quantification order should be [a,m,b] not [m,a,b].
+ (tyCoFVsOfType arg `unionFV` tyCoFVsOfType w `unionFV` tyCoFVsOfType res) f bound_vars acc
tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc
tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc
tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc
@@ -958,7 +960,9 @@ invisibleVarsOfType = go
= go ty'
go (TyVarTy v) = go (tyVarKind v)
go (AppTy f a) = go f `unionFV` go a
- go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2
+ go (FunTy _ w ty1 ty2) =
+ -- As per #23764, order is: arg, mult, res.
+ go ty1 `unionFV` go w `unionFV` go ty2
go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV`
invisibleVarsOfTypes visibles
where (invisibles, visibles) = partitionInvisibleTypes tc tys
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1984,7 +1984,9 @@ foldTyCo (TyCoFolder { tcf_view = view
go_ty _ (LitTy {}) = mempty
go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co
go_ty env (CoercionTy co) = go_co env co
- go_ty env (FunTy _ w arg res) = go_ty env w `mappend` go_ty env arg `mappend` go_ty env res
+ go_ty env (FunTy _ w arg res) =
+ -- As per #23764, ordering is [arg, w, res].
+ go_ty env arg `mappend` go_ty env w `mappend` go_ty env res
go_ty env (TyConApp _ tys) = go_tys env tys
go_ty env (ForAllTy (Bndr tv vis) inner)
= let !env' = tycobinder env tv vis -- Avoid building a thunk here
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -329,15 +329,8 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
stub_c_file_exists
<- outputForeignStubs_help stub_c stub_c_output_w
- ("#define IN_STG_CODE 0\n" ++
- "#include <Rts.h>\n" ++
- rts_includes ++
- ffi_includes ++
- cplusplus_hdr)
- cplusplus_ftr
- -- We're adding the default hc_header to the stub file, but this
- -- isn't really HC code, so we need to define IN_STG_CODE==0 to
- -- avoid the register variables etc. being enabled.
+ (rts_includes ++
+ ffi_includes) ""
return (stub_h_file_exists, if stub_c_file_exists
then Just stub_c
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -640,6 +640,9 @@ hsLTyVarName = hsTyVarName . unLoc
hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]
hsLTyVarNames = mapMaybe hsLTyVarName
+hsQTvExplicit :: LHsQTyVars (GhcPass p) -> [LHsTyVarBndr (HsBndrVis (GhcPass p)) (GhcPass p)]
+hsQTvExplicit = hsq_explicit
+
hsForAllTelescopeBndrs :: HsForAllTelescope (GhcPass p) -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)]
hsForAllTelescopeBndrs (HsForAllVis _ bndrs) = map (fmap (setHsTyVarBndrFlag Required)) bndrs
hsForAllTelescopeBndrs (HsForAllInvis _ bndrs) = map (fmap (updateHsTyVarBndrFlag Invisible)) bndrs
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1432,7 +1432,7 @@ collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty
-- Uses accumulating-parameter style
go dv (AppTy t1 t2) = foldlM go dv [t1, t2]
go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys
- go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res]
+ go dv (FunTy _ w arg res) = foldlM go dv [arg, w, res]
go dv (LitTy {}) = return dv
go dv (CastTy ty co) = do { dv1 <- go dv ty
; collect_cand_qtvs_co orig_ty cur_lvl bound dv1 co }
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -1009,8 +1009,8 @@ tcTyFamInstsAndVisX = go
go _ (LitTy {}) = []
go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr)
++ go is_invis_arg ty
- go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg w
- ++ go is_invis_arg ty1
+ go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg ty1
+ ++ go is_invis_arg w
++ go is_invis_arg ty2
go is_invis_arg ty@(AppTy _ _) =
let (ty_head, ty_args) = splitAppTys ty
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -216,7 +216,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -55,7 +55,6 @@ module Language.Haskell.Syntax.Type (
FieldOcc(..), LFieldOcc,
mapHsOuterImplicit,
- hsQTvExplicit,
isHsKindedTyVar
) where
@@ -68,7 +67,6 @@ import Language.Haskell.Syntax.Specificity
import GHC.Hs.Doc (LHsDoc)
import GHC.Data.FastString (FastString)
-import GHC.Utils.Panic( panic )
import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.Maybe
@@ -326,10 +324,6 @@ data LHsQTyVars pass -- See Note [HsType binders]
}
| XLHsQTyVars !(XXLHsQTyVars pass)
-hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass]
-hsQTvExplicit (HsQTvs { hsq_explicit = explicit_tvs }) = explicit_tvs
-hsQTvExplicit (XLHsQTyVars {}) = panic "hsQTvExplicit"
-
------------------------------------------------
-- HsOuterTyVarBndrs
-- Used to quantify the outermost type variable binders of a type that obeys
=====================================
configure.ac
=====================================
@@ -526,7 +526,7 @@ AC_SUBST(InstallNameToolCmd)
# versions of LLVM simultaneously, but that stopped working around
# 3.5/3.6 release of LLVM.
LlvmMinVersion=13 # inclusive
-LlvmMaxVersion=21 # not inclusive
+LlvmMaxVersion=22 # not inclusive
AC_SUBST([LlvmMinVersion])
AC_SUBST([LlvmMaxVersion])
=====================================
libraries/base/src/GHC/Num.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
@@ -16,11 +17,190 @@ module GHC.Num
( Num(..)
, subtract
, quotRemInteger
- , module GHC.Num.Integer
- , module GHC.Num.Natural
+ , integerFromNatural
+ , integerToNaturalClamp
+ , integerToNaturalThrow
+ , integerToNatural
+ , integerToWord#
+ , integerToInt#
+ , integerToWord64#
+ , integerToInt64#
+ , integerAdd
+ , integerMul
+ , integerSub
+ , integerNegate
+ , integerAbs
+ , integerPopCount#
+ , integerQuot
+ , integerRem
+ , integerDiv
+ , integerMod
+ , integerDivMod#
+ , integerQuotRem#
+ , integerEncodeFloat#
+ , integerEncodeDouble#
+ , integerGcd
+ , integerLcm
+ , integerAnd
+ , integerOr
+ , integerXor
+ , integerComplement
+ , integerBit#
+ , integerTestBit#
+ , integerShiftL#
+ , integerShiftR#
+ , integerFromWord#
+ , integerFromWord64#
+ , integerFromInt64#
+ , Integer(..)
+ , integerBit
+ , integerCheck
+ , integerCheck#
+ , integerCompare
+ , integerDecodeDouble#
+ , integerDivMod
+ , integerEncodeDouble
+ , integerEq
+ , integerEq#
+ , integerFromAddr
+ , integerFromAddr#
+ , integerFromBigNat#
+ , integerFromBigNatNeg#
+ , integerFromBigNatSign#
+ , integerFromByteArray
+ , integerFromByteArray#
+ , integerFromInt
+ , integerFromInt#
+ , integerFromWord
+ , integerFromWordList
+ , integerFromWordNeg#
+ , integerFromWordSign#
+ , integerGcde
+ , integerGcde#
+ , integerGe
+ , integerGe#
+ , integerGt
+ , integerGt#
+ , integerIsNegative
+ , integerIsNegative#
+ , integerIsOne
+ , integerIsPowerOf2#
+ , integerIsZero
+ , integerLe
+ , integerLe#
+ , integerLog2
+ , integerLog2#
+ , integerLogBase
+ , integerLogBase#
+ , integerLogBaseWord
+ , integerLogBaseWord#
+ , integerLt
+ , integerLt#
+ , integerNe
+ , integerNe#
+ , integerOne
+ , integerPowMod#
+ , integerQuotRem
+ , integerRecipMod#
+ , integerShiftL
+ , integerShiftR
+ , integerSignum
+ , integerSignum#
+ , integerSizeInBase#
+ , integerSqr
+ , integerTestBit
+ , integerToAddr
+ , integerToAddr#
+ , integerToBigNatClamp#
+ , integerToBigNatSign#
+ , integerToInt
+ , integerToMutableByteArray
+ , integerToMutableByteArray#
+ , integerToWord
+ , integerZero
+ , naturalToWord#
+ , naturalPopCount#
+ , naturalShiftR#
+ , naturalShiftL#
+ , naturalAdd
+ , naturalSub
+ , naturalSubThrow
+ , naturalSubUnsafe
+ , naturalMul
+ , naturalQuotRem#
+ , naturalQuot
+ , naturalRem
+ , naturalAnd
+ , naturalAndNot
+ , naturalOr
+ , naturalXor
+ , naturalTestBit#
+ , naturalBit#
+ , naturalGcd
+ , naturalLcm
+ , naturalLog2#
+ , naturalLogBaseWord#
+ , naturalLogBase#
+ , naturalPowMod
+ , naturalSizeInBase#
+ , Natural(..)
+ , naturalBit
+ , naturalCheck
+ , naturalCheck#
+ , naturalClearBit
+ , naturalClearBit#
+ , naturalCompare
+ , naturalComplementBit
+ , naturalComplementBit#
+ , naturalEncodeDouble#
+ , naturalEncodeFloat#
+ , naturalEq
+ , naturalEq#
+ , naturalFromAddr
+ , naturalFromAddr#
+ , naturalFromBigNat#
+ , naturalFromByteArray#
+ , naturalFromWord
+ , naturalFromWord#
+ , naturalFromWord2#
+ , naturalFromWordList
+ , naturalGe
+ , naturalGe#
+ , naturalGt
+ , naturalGt#
+ , naturalIsOne
+ , naturalIsPowerOf2#
+ , naturalIsZero
+ , naturalLe
+ , naturalLe#
+ , naturalLog2
+ , naturalLogBase
+ , naturalLogBaseWord
+ , naturalLt
+ , naturalLt#
+ , naturalNe
+ , naturalNe#
+ , naturalNegate
+ , naturalOne
+ , naturalPopCount
+ , naturalQuotRem
+ , naturalSetBit
+ , naturalSetBit#
+ , naturalShiftL
+ , naturalShiftR
+ , naturalSignum
+ , naturalSqr
+ , naturalTestBit
+ , naturalToAddr
+ , naturalToAddr#
+ , naturalToBigNat#
+ , naturalToMutableByteArray#
+ , naturalToWord
+ , naturalToWordClamp
+ , naturalToWordClamp#
+ , naturalToWordMaybe#
+ , naturalZero
)
where
import GHC.Internal.Num
-import GHC.Num.Integer
-import GHC.Num.Natural
=====================================
testsuite/tests/cmm/opt/T25664.hs
=====================================
@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -O -fno-full-laziness #-}
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts
+import GHC.Int
+
+mb8 :: Int8 -> Int8
+{-# OPAQUE mb8 #-}
+mb8 (I8# i) = I8# (i `quotInt8#` (noinline intToInt8# 128#))
+
+mb16 :: Int16 -> Int16
+{-# OPAQUE mb16 #-}
+mb16 (I16# i) = I16# (i `quotInt16#` (noinline intToInt16# 32768#))
+
+main :: IO ()
+main = print (mb8 minBound) >> print (mb16 minBound)
+
=====================================
testsuite/tests/cmm/opt/T25664.stdout
=====================================
@@ -0,0 +1,2 @@
+1
+1
=====================================
testsuite/tests/cmm/opt/all.T
=====================================
@@ -12,3 +12,6 @@ test('T25771', [cmm_src, only_ways(['optasm']),
grep_errmsg(r'(12\.345|0\.6640625)',[1]),
],
compile, ['-ddump-cmm'])
+
+# Cmm should correctly account for word size when performing MUL/DIV/REM by a power of 2 optimization.
+test('T25664', normal, compile_and_run, [''])
\ No newline at end of file
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -11397,7 +11397,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -8569,7 +8569,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -435,7 +435,7 @@ ppFamHeader
| associated = id
| otherwise = (<+> keyword "family")
- famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs)
+ famName = ppAppDocNameTyVarBndrs unicode name (hsQTvExplicitBinders tvs)
famSig = case result of
NoSig _ -> empty
@@ -644,7 +644,7 @@ ppTyVars :: RenderableBndrFlag flag => Bool -> [LHsTyVarBndr flag DocNameI] -> [
ppTyVars unicode tvs = map (ppHsTyVarBndr unicode . unLoc) tvs
tyvarNames :: LHsQTyVars DocNameI -> [Maybe Name]
-tyvarNames = map (fmap getName . hsLTyVarNameI) . hsQTvExplicit
+tyvarNames = map (fmap getName . hsLTyVarNameI) . hsQTvExplicitBinders
declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
declWithDoc decl doc =
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -468,7 +468,7 @@ ppTySyn
hdr =
hsep
( [keyword "type", ppBinder summary occ]
- ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)
+ ++ ppTyVars unicode qual (hsQTvExplicitBinders ltyvars)
)
full = hdr <+> def
def = case unLoc ltype of
@@ -595,7 +595,7 @@ ppFamHeader
qual =
hsep
[ ppFamilyLeader associated info
- , ppAppDocNameTyVarBndrs summary unicode qual name (hsq_explicit tvs)
+ , ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicitBinders tvs)
, ppResultSig result unicode qual
, injAnn
, whereBit
@@ -760,7 +760,7 @@ ppClassHdr
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
<+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
- <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)
+ <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicitBinders tvs)
<+> ppFds fds unicode qual
ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html
@@ -1656,7 +1656,7 @@ ppDataHeader
ppLContext ctxt unicode qual HideEmptyContexts
<+>
-- T a b c ..., or a :+: b
- ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs)
+ ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicitBinders tvs)
<+> case ks of
Nothing -> mempty
Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -29,7 +29,7 @@ module Haddock.Convert
import Control.DeepSeq (force)
import Data.Either (lefts, partitionEithers, rights)
-import Data.Maybe (catMaybes, mapMaybe, maybeToList)
+import Data.Maybe (catMaybes, mapMaybe)
import GHC.Builtin.Names
( boxedRepDataConKey
, eqTyConKey
@@ -140,7 +140,7 @@ tyThingToLHsDecl prr t = case t of
hsq_explicit $
fdTyVars fd
, feqn_fixity = fdFixity fd
- , feqn_rhs = synifyType WithinType [] rhs
+ , feqn_rhs = synifyType WithinType emptyVarSet rhs
}
extractAtItem
@@ -179,7 +179,7 @@ tyThingToLHsDecl prr t = case t of
noLocA (MinimalSig (noAnn, NoSourceText) . noLocA $ classMinimalDef cl)
: [ noLocA tcdSig
| clsOp <- classOpItems cl
- , tcdSig <- synifyTcIdSig vs clsOp
+ , tcdSig <- synifyTcIdSig (mkVarSet vs) clsOp
]
, tcdMeths = [] -- ignore default method definitions, they don't affect signature
-- class associated-types are a subset of TyCon:
@@ -213,9 +213,9 @@ synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn
synifyAxBranch tc (CoAxBranch{cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs}) =
let name = synifyNameN tc
args_types_only = filterOutInvisibleTypes tc args
- typats = map (synifyType WithinType []) args_types_only
+ typats = map (synifyType WithinType emptyVarSet) args_types_only
annot_typats = zipWith3 annotHsType args_poly args_types_only typats
- hs_rhs = synifyType WithinType [] rhs
+ hs_rhs = synifyType WithinType emptyVarSet rhs
outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs}
in -- TODO: this must change eventually
FamEqn
@@ -344,7 +344,7 @@ synifyTyCon _prr coax tc
, tcdLName = synifyNameN tc
, tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = synifyFixity tc
- , tcdRhs = synifyType WithinType [] ty
+ , tcdRhs = synifyType WithinType emptyVarSet ty
}
-- (closed) newtype and data
| otherwise = do
@@ -578,8 +578,8 @@ synifyDataCon use_gadt_syntax dc =
linear_tys =
zipWith
( \(Scaled mult ty) (HsSrcBang st unp str) ->
- let tySyn = synifyType WithinType [] ty
- multSyn = synifyMultRec [] mult
+ let tySyn = synifyType WithinType emptyVarSet ty
+ multSyn = synifyMultRec emptyVarSet mult
in CDF (noAnn, st) unp str multSyn tySyn Nothing
)
arg_tys
@@ -620,7 +620,7 @@ synifyDataCon use_gadt_syntax dc =
, con_inner_bndrs = inner_bndrs
, con_mb_cxt = ctx
, con_g_args = hat
- , con_res_ty = synifyType WithinType [] res_ty
+ , con_res_ty = synifyType WithinType emptyVarSet res_ty
, con_doc = Nothing
}
else do
@@ -657,11 +657,11 @@ synifyIdSig
-> SynifyTypeState
-- ^ what to do with a 'forall'
-> [TyVar]
- -- ^ free variables in the type to convert
+ -- ^ type variables bound from an outer scope
-> Id
-- ^ the 'Id' from which to get the type signature
-> Sig GhcRn
-synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t)
+synifyIdSig prr s boundTvs i = TypeSig noAnn [n] (synifySigWcType s boundTvs t)
where
!n = force $ synifyNameN i
t = defaultType prr (varType i)
@@ -669,18 +669,18 @@ synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t)
-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going
-- to contain the synified 'ClassOpSig' as well (when appropriate) a default
-- 'ClassOpSig'.
-synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn]
-synifyTcIdSig vs (i, dm) =
+synifyTcIdSig :: TyVarSet -> ClassOpItem -> [Sig GhcRn]
+synifyTcIdSig boundTvs (i, dm) =
[ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i))]
++ [ ClassOpSig noAnn True [noLocA dn] (defSig dt)
| Just (dn, GenericDM dt) <- [dm]
]
where
- mainSig t = synifySigType DeleteTopLevelQuantification vs t
- defSig t = synifySigType ImplicitizeForAll vs t
+ mainSig t = synifySigType DeleteTopLevelQuantification boundTvs t
+ defSig t = synifySigType ImplicitizeForAll boundTvs t
synifyCtx :: [PredType] -> LHsContext GhcRn
-synifyCtx ts = noLocA (map (synifyType WithinType []) ts)
+synifyCtx ts = noLocA (map (synifyType WithinType emptyVarSet) ts)
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
synifyTyVars ktvs =
@@ -699,7 +699,7 @@ synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv
-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind
--- signatures (even if they don't have the lifted type kind).
+-- signatures (even if they don't have kind 'Type').
synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
synify_ty_var no_kinds flag tv =
noLocA (HsTvb noAnn flag bndr_var bndr_kind)
@@ -726,7 +726,7 @@ annotHsType _ _ hs_ty@(L _ (HsKindSig{})) = hs_ty
annotHsType True ty hs_ty
| not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty =
let ki = typeKind ty
- hs_ki = synifyType WithinType [] ki
+ hs_ki = synifyType WithinType emptyVarSet ki
in noLocA (HsKindSig noAnn hs_ty hs_ki)
annotHsType _ _ hs_ty = hs_ty
@@ -768,14 +768,15 @@ data SynifyTypeState
-- the defining class gets to quantify all its functions for free!
DeleteTopLevelQuantification
-synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
+synifySigType :: SynifyTypeState -> TyVarSet -> Type -> LHsSigType GhcRn
-- The use of mkEmptySigType (which uses empty binders in OuterImplicit)
-- is a bit suspicious; what if the type has free variables?
-synifySigType s vs ty = mkEmptySigType (synifyType s vs ty)
+synifySigType s boundTvs ty = mkEmptySigType (synifyType s boundTvs ty)
synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
-- Ditto (see synifySigType)
-synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (rename (map getName vs) $ synifyType s vs ty))
+synifySigWcType s vs ty =
+ mkEmptyWildCardBndrs (mkEmptySigType (rename (map getName vs) $ synifyType s (mkVarSet vs) ty))
synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
-- Ditto (see synifySigType)
@@ -791,13 +792,13 @@ defaultType HideRuntimeRep = defaultRuntimeRepVars
synifyType
:: SynifyTypeState
-- ^ what to do with a 'forall'
- -> [TyVar]
- -- ^ free variables in the type to convert
+ -> TyVarSet
+ -- ^ bound type variables
-> Type
-- ^ the type to convert
-> LHsType GhcRn
synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (noUserRdr $ getName tv)
-synifyType _ vs (TyConApp tc tys) =
+synifyType _ boundTvs (TyConApp tc tys) =
maybe_sig res_ty
where
res_ty :: LHsType GhcRn
@@ -819,24 +820,24 @@ synifyType _ vs (TyConApp tc tys) =
ConstraintTuple -> HsBoxedOrConstraintTuple
UnboxedTuple -> HsUnboxedTuple
)
- (map (synifyType WithinType vs) vis_tys)
+ (map (synifyType WithinType boundTvs) vis_tys)
| isUnboxedSumTyCon tc =
- noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys)
+ noLocA $ HsSumTy noAnn (map (synifyType WithinType boundTvs) vis_tys)
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
, dataConSourceArity dc == length vis_tys =
- noLocA $ HsExplicitTupleTy noExtField IsPromoted (map (synifyType WithinType vs) vis_tys)
+ noLocA $ HsExplicitTupleTy noExtField IsPromoted (map (synifyType WithinType boundTvs) vis_tys)
-- ditto for lists
| getName tc == listTyConName
, [ty] <- vis_tys =
- noLocA $ HsListTy noAnn (synifyType WithinType vs ty)
+ noLocA $ HsListTy noAnn (synifyType WithinType boundTvs ty)
| tc == promotedNilDataCon
, [] <- vis_tys =
noLocA $ HsExplicitListTy noExtField IsPromoted []
| tc == promotedConsDataCon
, [ty1, ty2] <- vis_tys =
- let hTy = synifyType WithinType vs ty1
- in case synifyType WithinType vs ty2 of
+ let hTy = synifyType WithinType boundTvs ty1
+ in case synifyType WithinType boundTvs ty2 of
tTy
| L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy ->
noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')
@@ -846,7 +847,7 @@ synifyType _ vs (TyConApp tc tys) =
| tc `hasKey` ipClassKey
, [name, ty] <- tys
, Just x <- isStrLitTy name =
- noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty)
+ noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType boundTvs ty)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys =
@@ -854,9 +855,9 @@ synifyType _ vs (TyConApp tc tys) =
HsOpTy
noExtField
NotPromoted
- (synifyType WithinType vs ty1)
+ (synifyType WithinType boundTvs ty1)
(noLocA $ noUserRdr eqTyConName)
- (synifyType WithinType vs ty2)
+ (synifyType WithinType boundTvs ty2)
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1 : ty2 : tys_rest <- vis_tys =
@@ -864,9 +865,9 @@ synifyType _ vs (TyConApp tc tys) =
( HsOpTy
noExtField
prom
- (synifyType WithinType vs ty1)
+ (synifyType WithinType boundTvs ty1)
(noLocA $ noUserRdr $ getName tc)
- (synifyType WithinType vs ty2)
+ (synifyType WithinType boundTvs ty2)
)
tys_rest
-- Most TyCons:
@@ -880,7 +881,7 @@ synifyType _ vs (TyConApp tc tys) =
foldl
(\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2)
(noLocA ty_app)
- ( map (synifyType WithinType vs) $
+ ( map (synifyType WithinType boundTvs) $
filterOut isCoercionTy ty_args
)
@@ -891,56 +892,57 @@ synifyType _ vs (TyConApp tc tys) =
maybe_sig ty'
| tyConAppNeedsKindSig False tc tys_len =
let full_kind = typeKind (mkTyConApp tc tys)
- full_kind' = synifyType WithinType vs full_kind
+ full_kind' = synifyType WithinType boundTvs full_kind
in noLocA $ HsKindSig noAnn ty' full_kind'
| otherwise = ty'
-synifyType _ vs ty@(AppTy{}) =
+synifyType _ boundTvs ty@(AppTy{}) =
let
(ty_head, ty_args) = splitAppTys ty
- ty_head' = synifyType WithinType vs ty_head
+ ty_head' = synifyType WithinType boundTvs ty_head
ty_args' =
- map (synifyType WithinType vs) $
+ map (synifyType WithinType boundTvs) $
filterOut isCoercionTy $
filterByList
(map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args)
ty_args
in
foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args'
-synifyType s vs funty@(FunTy af w t1 t2)
- | isInvisibleFunArg af = synifySigmaType s vs funty
+synifyType s boundTvs funty@(FunTy af w t1 t2)
+ | isInvisibleFunArg af = synifySigmaType s boundTvs funty
| otherwise = noLocA $ HsFunTy noExtField w' s1 s2
where
- s1 = synifyType WithinType vs t1
- s2 = synifyType WithinType vs t2
- w' = synifyMultArrow vs w
-synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
+ s1 = synifyType WithinType boundTvs t1
+ s2 = synifyType WithinType boundTvs t2
+ w' = synifyMultArrow boundTvs w
+synifyType s boundTvs forallty@(ForAllTy (Bndr _ argf) _ty) =
case argf of
- Required -> synifyVisForAllType vs forallty
- Invisible _ -> synifySigmaType s vs forallty
+ Required -> synifyVisForAllType boundTvs forallty
+ Invisible _ -> synifySigmaType s boundTvs forallty
synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t
-synifyType s vs (CastTy t _) = synifyType s vs t
+synifyType s boundTvs (CastTy t _) = synifyType s boundTvs t
synifyType _ _ (CoercionTy{}) = error "synifyType:Coercion"
-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType'
synifyVisForAllType
- :: [TyVar]
- -- ^ free variables in the type to convert
+ :: TyVarSet
+ -- ^ bound type variables
-> Type
-- ^ the forall type to convert
-> LHsType GhcRn
-synifyVisForAllType vs ty =
+synifyVisForAllType boundTvs ty =
let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty
- sTvs = map synifyTyVarBndr tvs
+ sTvs = map (synifyTyVarBndr' noKindSigTvs) tvs
+ noKindSigTvs = noKindSigTyVars ty
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
- tvs' = orderedFVs (mkVarSet vs) [rho]
+ tvs' = orderedFVs boundTvs [rho]
in noLocA $
HsForAllTy
{ hst_tele = mkHsForAllVisTele noAnn sTvs
, hst_xforall = noExtField
- , hst_body = synifyType WithinType (tvs' ++ vs) rho
+ , hst_body = synifyType WithinType (extendVarSetList boundTvs tvs') rho
}
-- | Process a 'Type' which starts with an invisible @forall@ or a constraint
@@ -948,18 +950,18 @@ synifyVisForAllType vs ty =
synifySigmaType
:: SynifyTypeState
-- ^ what to do with the 'forall'
- -> [TyVar]
- -- ^ free variables in the type to convert
+ -> TyVarSet
+ -- ^ bound type variables
-> Type
-- ^ the forall type to convert
-> LHsType GhcRn
-synifySigmaType s vs ty =
+synifySigmaType s boundTvs ty =
let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty
sPhi =
HsQualTy
{ hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
- , hst_body = synifyType WithinType (tvs' ++ vs) tau
+ , hst_body = synifyType WithinType (extendVarSetList boundTvs tvs' ) tau
}
sTy =
@@ -969,49 +971,56 @@ synifySigmaType s vs ty =
, hst_body = noLocA sPhi
}
- sTvs = map synifyTyVarBndr tvs
+ sTvs = map (synifyTyVarBndr' noKindSigTvs) tvs
+
+ noKindSigTvs = noKindSigTyVars ty
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
- tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])
+ tvs' = orderedFVs boundTvs (ctx ++ [tau])
in case s of
- DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau
+ DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (extendVarSetList boundTvs tvs') tau
-- Put a forall in if there are any type variables
WithinType
| not (null tvs) -> noLocA sTy
| otherwise -> noLocA sPhi
- ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
+ ImplicitizeForAll -> implicitForAll boundTvs tvs ctx (synifyType WithinType) tau
--- | Put a forall in if there are any type variables which require
--- explicit kind annotations or if the inferred type variable order
--- would be different.
+-- | Use an explicit forall if there are any type variables which require
+-- explicit kind annotations or if the inferred type variable quantification
+-- order would be different.
implicitForAll
- :: [TyCon]
- -- ^ type constructors that determine their args kinds
- -> [TyVar]
- -- ^ free variables in the type to convert
+ :: TyVarSet
+ -- ^ bound type variables (e.g. bound from an outer scope)
-> [InvisTVBinder]
-- ^ type variable binders in the forall
-> ThetaType
-- ^ constraints right after the forall
- -> ([TyVar] -> Type -> LHsType GhcRn)
+ -> (TyVarSet -> Type -> LHsType GhcRn)
-- ^ how to convert the inner type
-> Type
-- ^ inner type
-> LHsType GhcRn
-implicitForAll tycons vs tvs ctx synInner tau
- | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy
- | tvs' /= (binderVars tvs) = noLocA sTy
- | otherwise = noLocA sPhi
+implicitForAll boundTvs tvbs ctx synInner tau
+ | any (isHsKindedTyVar . unLoc) sTvs
+ -- Explicit forall: some type variable needs an explicit kind annotation.
+ = noLocA sTy
+ | tvs /= inferredFreeTvs
+ -- Explicit forall: the inferred quantification order would be different.
+ = noLocA sTy
+ | otherwise
+ -- Implicit forall.
+ = noLocA sPhi
where
- sRho = synInner (tvs' ++ vs) tau
+ tvs = binderVars tvbs
+ sRho = synInner (extendVarSetList boundTvs inferredFreeTvs) tau
sPhi
| null ctx = unLoc sRho
| otherwise =
HsQualTy
{ hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
- , hst_body = synInner (tvs' ++ vs) tau
+ , hst_body = sRho
}
sTy =
HsForAllTy
@@ -1020,84 +1029,129 @@ implicitForAll tycons vs tvs ctx synInner tau
, hst_body = noLocA sPhi
}
- no_kinds_needed = noKindTyVars tycons tau
- sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs
+ no_kinds_needed = noKindSigTyVars tau
+ sTvs = map (synifyTyVarBndr' no_kinds_needed) tvbs
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
- tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])
+ inferredFreeTvs = orderedFVs boundTvs (ctx ++ [tau])
--- | Find the set of type variables whose kind signatures can be properly
--- inferred just from their uses in the type signature. This means the type
--- variable to has at least one fully applied use @f x1 x2 ... xn@ where:
+-- | Returns a subset of the free type variables of the given type whose kinds
+-- can definitely be inferred from their occurrences in the type.
--
--- * @f@ has a function kind where the arguments have the same kinds
--- as @x1 x2 ... xn@.
+-- This function is only a simple heuristic, which is used in order to avoid
+-- needlessly cluttering Haddocks with explicit foralls that are not needed.
+-- This function may return some type variables for which we aren't sure
+-- (which will cause us to display the type with an explicit forall, just in
+-- case).
--
--- * @f@ has a function kind whose final return has lifted type kind
-noKindTyVars
- :: [TyCon]
- -- ^ type constructors that determine their args kinds
- -> Type
+-- In the future, we hope to address the issue of whether to print a type with
+-- an explicit forall by storing whether the user wrote the type with an
+-- explicit forall in the first place (see GHC ticket #26271).
+noKindSigTyVars
+ :: Type
-- ^ type to inspect
-> VarSet
- -- ^ set of variables whose kinds can be inferred from uses in the type
-noKindTyVars _ (TyVarTy var)
- | isLiftedTypeKind (tyVarKind var) = unitVarSet var
-noKindTyVars ts ty
- | (f, xs) <- splitAppTys ty
- , not (null xs) =
- let args = map (noKindTyVars ts) xs
- func = case f of
- TyVarTy var
- | (xsKinds, outKind) <- splitFunTys (tyVarKind var)
- , map scaledThing xsKinds `eqTypes` map typeKind xs
- , isLiftedTypeKind outKind ->
- unitVarSet var
- TyConApp t ks
- | t `elem` ts
- , all noFreeVarsOfType ks ->
- mkVarSet [v | TyVarTy v <- xs]
- _ -> noKindTyVars ts f
- in unionVarSets (func : args)
-noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t
-noKindTyVars ts (FunTy _ w t1 t2) =
- noKindTyVars ts w
- `unionVarSet` noKindTyVars ts t1
- `unionVarSet` noKindTyVars ts t2
-noKindTyVars ts (CastTy t _) = noKindTyVars ts t
-noKindTyVars _ _ = emptyVarSet
-
-synifyMultArrow :: [TyVar] -> Mult -> HsMultAnn GhcRn
-synifyMultArrow vs t = case t of
+ -- ^ set of variables whose kinds can definitely be inferred from occurrences in the type
+noKindSigTyVars ty
+ | Just ty' <- coreView ty
+ = noKindSigTyVars ty'
+ -- In a TyConApp 'T ty_1 ... ty_n', if 'ty_i = tv' is a type variable and the
+ -- i-th argument of the kind of 'T' is monomorphic, then the kind of 'tv'
+ -- is fully determined by its occurrence in the TyConApp.
+ | Just (tc, args) <- splitTyConApp_maybe ty
+ , let (tcArgBndrs, _tcResKi) = splitPiTys (tyConKind tc)
+ tcArgKis = map (\case { Named (Bndr b _) -> tyVarKind b; Anon (Scaled _ t) _ -> t}) tcArgBndrs
+ = mono_tvs tcArgKis args `unionVarSet` (mapUnionVarSet noKindSigTyVars args)
+ -- If we have 'f ty_1 ... ty_n' where 'f :: ki_1 -> ... -> ki_n -> Type'
+ -- then we can infer the kind of 'f' from the kinds of its arguments.
+ --
+ -- This special case handles common examples involving functors, monads...
+ -- with type signatures such as '(a -> b) -> (f a -> f b)'.
+ | (TyVarTy fun, args) <- splitAppTys ty
+ , not (null args)
+ , (funArgKinds, funResKind) <- splitFunTys (tyVarKind fun)
+ , map scaledThing funArgKinds `eqTypes` map typeKind args
+ , isLiftedTypeKind funResKind
+ = ( `extendVarSet` fun ) $ mapUnionVarSet noKindSigTyVars args
+ where
+ mono_tvs :: [Type] -> [Type] -> VarSet
+ mono_tvs (tcArgKi:tcArgKis) (arg:args)
+ | TyVarTy arg_tv <- arg
+ , noFreeVarsOfType tcArgKi
+ = ( `extendVarSet` arg_tv ) $ mono_tvs tcArgKis args
+ | otherwise
+ = mono_tvs tcArgKis args
+ mono_tvs _ _ = emptyVarSet
+noKindSigTyVars (ForAllTy _ t) = noKindSigTyVars t
+noKindSigTyVars (CastTy t _) = noKindSigTyVars t
+noKindSigTyVars _ = emptyVarSet
+
+synifyMultArrow :: TyVarSet -> Mult -> HsMultAnn GhcRn
+synifyMultArrow boundTvs t = case t of
OneTy -> HsLinearAnn noExtField
ManyTy -> HsUnannotated noExtField
- ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
+ ty -> HsExplicitMult noExtField (synifyType WithinType boundTvs ty)
-synifyMultRec :: [TyVar] -> Mult -> HsMultAnn GhcRn
-synifyMultRec vs t = case t of
+synifyMultRec :: TyVarSet -> Mult -> HsMultAnn GhcRn
+synifyMultRec boundTvs t = case t of
OneTy -> HsUnannotated noExtField
- ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
+ ty -> HsExplicitMult noExtField (synifyType WithinType boundTvs ty)
synifyPatSynType :: PatSyn -> LHsType GhcRn
synifyPatSynType ps =
- let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
- ts = maybeToList (tyConAppTyCon_maybe res_ty)
+ let (univ_tvbs, req_theta, ex_tvbs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
+
+{- Recall that pattern synonyms have both "required" and "provided" constraints,
+e.g.
+
+ pattern P :: forall a b c. req => forall e f g => prov => arg_ty1 -> ... -> res_ty
+
+Here:
+
+ a, b, c are universal type variables
+ req are required constraints
- -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
- -- i.e., an explicit empty context, which is what we need. This is not
- -- possible by taking theta = [], as that will print no context at all
+ e, f, g are existential type variables
+ prov are provided constraints
+
+The first pair comes from the outside, while the second pair is obtained upon
+a successful match on the pattern.
+
+Remarks:
+
+ 1. Both foralls are optional.
+
+ 2. If there is only one =>, we interpret the constraints as required.
+ Thus, if we want an empty set of required constraints and a non-empty set
+ of provided constraints, the type signature must be written like
+
+ () => prov => res_ty
+-}
+
+
+ -- Add an explicit "() => ..." when req_theta is empty but there are
+ -- existential variables or provided constraints.
req_theta'
| null req_theta
- , not (null prov_theta && null ex_tvs) =
+ , not (null prov_theta && null ex_tvbs) =
[unitTy]
| otherwise = req_theta
+ univ_tvs = mkVarSet $ binderVars univ_tvbs
+ ex_tvs = mkVarSet $ binderVars ex_tvbs
+
+
in implicitForAll
- ts
- []
- (univ_tvs ++ ex_tvs)
+ ex_tvs -- consider the ex_tvs non-free, so that we don't quantify over them here
+ univ_tvbs -- quantify only over the universals
req_theta'
- (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType))
+ ( \_ ->
+ implicitForAll
+ univ_tvs -- the univ_tvs are already bound
+ ex_tvbs -- quantify only over the existentials
+ prov_theta
+ (synifyType WithinType)
+ )
(mkScaledFunTys arg_tys res_ty)
synifyTyLit :: TyLit -> HsTyLit GhcRn
@@ -1106,7 +1160,7 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c
synifyKindSig :: Kind -> LHsKind GhcRn
-synifyKindSig k = synifyType WithinType [] k
+synifyKindSig k = synifyType WithinType emptyVarSet k
stripKindSig :: LHsType GhcRn -> LHsType GhcRn
stripKindSig (L _ (HsKindSig _ t _)) = t
@@ -1119,7 +1173,7 @@ synifyInstHead (vs, preds, cls, types) associated_families =
, ihdTypes = map unLoc annot_ts
, ihdInstType =
ClassInst
- { clsiCtx = map (unLoc . synifyType WithinType []) preds
+ { clsiCtx = map (unLoc . synifyType WithinType emptyVarSet) preds
, clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
, clsiSigs = map synifyClsIdSig $ specialized_class_methods
, clsiAssocTys =
@@ -1132,7 +1186,7 @@ synifyInstHead (vs, preds, cls, types) associated_families =
where
cls_tycon = classTyCon cls
ts = filterOutInvisibleTypes cls_tycon types
- ts' = map (synifyType WithinType vs) ts
+ ts' = map (synifyType WithinType $ mkVarSet vs) ts
annot_ts = zipWith3 annotHsType args_poly ts ts'
args_poly = tyConArgsPolyKinded cls_tycon
synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs
@@ -1151,7 +1205,7 @@ synifyFamInst fi opaque = do
where
ityp SynFamilyInst | opaque = return $ TypeInst Nothing
ityp SynFamilyInst =
- return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs
+ return . TypeInst . Just . unLoc $ synifyType WithinType emptyVarSet fam_rhs
ityp (DataFamilyInst c) =
DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c
fam_tc = famInstTyCon fi
@@ -1173,7 +1227,7 @@ synifyFamInst fi opaque = do
fam_lhs
ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs
- synifyTypes = map (synifyType WithinType [])
+ synifyTypes = map (synifyType WithinType emptyVarSet)
ts' = synifyTypes ts
annot_ts = zipWith3 annotHsType args_poly ts ts'
args_poly = tyConArgsPolyKinded fam_tc
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -333,9 +333,12 @@ lHsQTyVarsToTypes tvs =
[ HsValArg noExtField $ noLocA (case hsLTyVarName tv of
Nothing -> HsWildCardTy noExtField
Just nm -> HsTyVar noAnn NotPromoted (noLocA $ noUserRdr nm))
- | tv <- hsQTvExplicit tvs
+ | tv <- hsq_explicit tvs
]
+hsQTvExplicitBinders :: LHsQTyVars DocNameI -> [LHsTyVarBndr (HsBndrVis DocNameI) DocNameI]
+hsQTvExplicitBinders = hsq_explicit
+
--------------------------------------------------------------------------------
-- * Making abstract declarations
@@ -853,8 +856,8 @@ tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c
tyCoFVsOfType' (LitTy{}) a b c = emptyFV a b c
tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c
tyCoFVsOfType' (FunTy _ w arg res) a b c =
- ( tyCoFVsOfType' w
- `unionFV` tyCoFVsOfType' res
+ ( tyCoFVsOfType' res
+ `unionFV` tyCoFVsOfType' w
`unionFV` tyCoFVsOfType' arg
)
a
=====================================
utils/haddock/html-test/ref/Bug1050.html
=====================================
@@ -99,11 +99,7 @@
>mkT</a
> :: <span class="keyword"
>forall</span
- > {k} {f :: <span class="keyword"
- >forall</span
- > k1. k1 -> <a href="#" title="Data.Kind"
- >Type</a
- >} {a :: k}. f a -> <a href="#" title="Bug1050"
+ > {k} {f} {a :: k}. f a -> <a href="#" title="Bug1050"
>T</a
> f a <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/ref/LinearTypes.html
=====================================
@@ -64,11 +64,7 @@
><li class="src short"
><a href="#"
>poly</a
- > :: <span class="keyword"
- >forall</span
- > a (m :: <a href="#" title="GHC.Exts"
- >Multiplicity</a
- >) b. a %m -> b</li
+ > :: a %m -> b</li
><li class="src short"
><span class="keyword"
>data</span
@@ -163,11 +159,7 @@
><p class="src"
><a id="v:poly" class="def"
>poly</a
- > :: <span class="keyword"
- >forall</span
- > a (m :: <a href="#" title="GHC.Exts"
- >Multiplicity</a
- >) b. a %m -> b <a href="#" class="selflink"
+ > :: a %m -> b <a href="#" class="selflink"
>#</a
></p
><div class="doc"
=====================================
utils/haddock/html-test/ref/PatternSyns.html
=====================================
@@ -132,7 +132,9 @@
>pattern</span
> <a href="#"
>E</a
- > :: a <a href="#" title="PatternSyns"
+ > :: <span class="keyword"
+ >forall</span
+ > {k} {a} {b :: k}. a <a href="#" title="PatternSyns"
>><</a
> b</li
><li class="src short"
@@ -335,7 +337,9 @@
>pattern</span
> <a id="v:E" class="def"
>E</a
- > :: a <a href="#" title="PatternSyns"
+ > :: <span class="keyword"
+ >forall</span
+ > {k} {a} {b :: k}. a <a href="#" title="PatternSyns"
>><</a
> b <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/ref/PatternSyns2.html
=====================================
@@ -0,0 +1,160 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><meta name="viewport" content="width=device-width, initial-scale=1"
+ /><title
+ >PatternSyns2</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script type="text/x-mathjax-config"
+ >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-…" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><span class="caption empty"
+ > </span
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >Index</a
+ ></li
+ ></ul
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >None</td
+ ></tr
+ ><tr
+ ><th
+ >Language</th
+ ><td
+ >Haskell2010</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >PatternSyns2</p
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P1" class="def"
+ >P1</a
+ > :: () => <a href="#" title="Prelude"
+ >Num</a
+ > a => a -> D <a href="#" title="Prelude"
+ >Num</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P2" class="def"
+ >P2</a
+ > :: <a href="#" title="Prelude"
+ >Num</a
+ > a => a -> a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P3" class="def"
+ >P3</a
+ > :: () => <span class="keyword"
+ >forall</span
+ > (e :: <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > '<a href="#" title="GHC.Exts"
+ >DoubleRep</a
+ >). <span class="breakable"
+ >(<span class="unbreakable"
+ >PCIR a</span
+ >, <span class="unbreakable"
+ >PCDR e</span
+ >)</span
+ > => a -> e -> Q a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P4" class="def"
+ >P4</a
+ > :: RCIR a => <span class="keyword"
+ >forall</span
+ > (e :: <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > '<a href="#" title="GHC.Exts"
+ >DoubleRep</a
+ >). <span class="breakable"
+ >(<span class="unbreakable"
+ >PCIR a</span
+ >, <span class="unbreakable"
+ >PCDR e</span
+ >)</span
+ > => a -> e -> Q a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P5" class="def"
+ >P5</a
+ > :: RCIR a => <span class="keyword"
+ >forall</span
+ > (e :: <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > '<a href="#" title="GHC.Exts"
+ >DoubleRep</a
+ >). a -> e -> Q a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P" class="def"
+ >P</a
+ > :: () => <span class="keyword"
+ >forall</span
+ > k (a :: k) b. <a href="#" title="Prelude"
+ >Show</a
+ > b => <a href="#" title="Data.Proxy"
+ >Proxy</a
+ > a -> b -> A <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></div
+ ></div
+ ></body
+ ></html
+>
=====================================
utils/haddock/html-test/ref/TypeOperators.html
=====================================
@@ -185,17 +185,7 @@
><p class="src"
><a id="v:biO" class="def"
>biO</a
- > :: <span class="keyword"
- >forall</span
- > (g :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- >) (f :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- >) a. <a href="#" title="TypeOperators"
+ > :: <a href="#" title="TypeOperators"
>O</a
> g f a <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/src/PatternSyns2.hs
=====================================
@@ -0,0 +1,60 @@
+{-# LANGUAGE Haskell2010 #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module PatternSyns2
+ ( pattern P1, pattern P2, pattern P3, pattern P4, pattern P5
+ , pattern P
+ )
+ where
+
+import Data.Kind
+import Data.Proxy
+import GHC.Exts
+
+type D :: ( Type -> Constraint ) -> Type -> Type
+data D c a where
+ MkD :: c a => a -> D c a
+
+pattern P1 :: () => Num a => a -> D Num a
+pattern P1 a = MkD a
+
+pattern P2 :: Num a => () => a -> a
+pattern P2 a = a
+
+type RCIR :: TYPE IntRep -> Constraint
+class RCIR a where
+
+type PCIR :: TYPE IntRep -> Constraint
+class PCIR a where
+
+type PCDR :: TYPE DoubleRep -> Constraint
+class PCDR a where
+
+type Q :: TYPE IntRep -> Type
+data Q a where
+ MkQ :: forall ( a :: TYPE IntRep ) ( e :: TYPE DoubleRep )
+ . ( PCIR a, PCDR e )
+ => a -> e -> Q a
+
+pattern P3 :: forall (a :: TYPE IntRep). () => forall (e :: TYPE DoubleRep). (PCIR a, PCDR e) => a -> e -> Q a
+pattern P3 a e = MkQ a e
+
+pattern P4 :: forall (a :: TYPE IntRep). (RCIR a) => forall (e :: TYPE DoubleRep). (PCIR a, PCDR e) => a -> e -> Q a
+pattern P4 a e = MkQ a e
+
+pattern P5 :: forall (a :: TYPE IntRep). (RCIR a) => forall (e :: TYPE DoubleRep). () => a -> e -> Q a
+pattern P5 a e <- MkQ a e
+
+
+type A :: Type
+data A where
+ MkA :: forall k (a ::k) b. ( Show b ) => Proxy a -> b -> A
+
+pattern P :: forall . () => forall k (a :: k) b. ( Show b ) => Proxy a -> b -> A
+pattern P a b = MkA a b
=====================================
utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
=====================================
@@ -24,7 +24,7 @@ Does something linear.\par}
\end{haddockdesc}
\begin{haddockdesc}
\item[\begin{tabular}{@{}l}
-poly :: forall a (m :: Multiplicity) b. a {\char '45}m -> b
+poly :: a {\char '45}m -> b
\end{tabular}]
{\haddockbegindoc
Does something polymorphic.\par}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b9233b299cdf3970dee2e735b92a05…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b9233b299cdf3970dee2e735b92a05…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26625] base: deprecate GHC internals in GHC.Num
by Teo Camarasu (＠teo) 12 Dec '25
by Teo Camarasu (＠teo) 12 Dec '25
12 Dec '25
Teo Camarasu pushed to branch wip/T26625 at Glasgow Haskell Compiler / GHC
Commits:
90813e70 by Teo Camarasu at 2025-12-12T10:51:35+00:00
base: deprecate GHC internals in GHC.Num
Implements CLC proposal: https://github.com/haskell/core-libraries-committee/issues/360
- - - - -
1 changed file:
- libraries/base/src/GHC/Num.hs
Changes:
=====================================
libraries/base/src/GHC/Num.hs
=====================================
@@ -15,191 +15,366 @@
module GHC.Num
( Num(..)
+ , Integer(..)
+ , Natural(..)
, subtract
, quotRemInteger
- , integerFromNatural
- , integerToNaturalClamp
- , integerToNaturalThrow
- , integerToNatural
- , integerToWord#
- , integerToInt#
- , integerToWord64#
- , integerToInt64#
- , integerAdd
- , integerMul
- , integerSub
- , integerNegate
- , integerAbs
- , integerPopCount#
- , integerQuot
- , integerRem
- , integerDiv
- , integerMod
- , integerDivMod#
- , integerQuotRem#
- , integerEncodeFloat#
- , integerEncodeDouble#
- , integerGcd
- , integerLcm
- , integerAnd
- , integerOr
- , integerXor
- , integerComplement
- , integerBit#
- , integerTestBit#
- , integerShiftL#
- , integerShiftR#
- , integerFromWord#
- , integerFromWord64#
- , integerFromInt64#
- , Integer(..)
- , integerBit
- , integerCheck
- , integerCheck#
- , integerCompare
- , integerDecodeDouble#
- , integerDivMod
- , integerEncodeDouble
- , integerEq
- , integerEq#
- , integerFromAddr
- , integerFromAddr#
- , integerFromBigNat#
- , integerFromBigNatNeg#
- , integerFromBigNatSign#
- , integerFromByteArray
- , integerFromByteArray#
- , integerFromInt
- , integerFromInt#
+ , integerToWord
, integerFromWord
- , integerFromWordList
- , integerFromWordNeg#
- , integerFromWordSign#
- , integerGcde
- , integerGcde#
- , integerGe
- , integerGe#
- , integerGt
- , integerGt#
- , integerIsNegative
- , integerIsNegative#
- , integerIsOne
- , integerIsPowerOf2#
- , integerIsZero
- , integerLe
- , integerLe#
- , integerLog2
- , integerLog2#
- , integerLogBase
- , integerLogBase#
- , integerLogBaseWord
- , integerLogBaseWord#
- , integerLt
- , integerLt#
- , integerNe
- , integerNe#
- , integerOne
- , integerPowMod#
- , integerQuotRem
- , integerRecipMod#
- , integerShiftL
- , integerShiftR
- , integerSignum
- , integerSignum#
- , integerSizeInBase#
- , integerSqr
- , integerTestBit
- , integerToAddr
- , integerToAddr#
- , integerToBigNatClamp#
- , integerToBigNatSign#
, integerToInt
- , integerToMutableByteArray
- , integerToMutableByteArray#
- , integerToWord
- , integerZero
- , naturalToWord#
- , naturalPopCount#
- , naturalShiftR#
- , naturalShiftL#
- , naturalAdd
- , naturalSub
- , naturalSubThrow
- , naturalSubUnsafe
- , naturalMul
- , naturalQuotRem#
- , naturalQuot
- , naturalRem
- , naturalAnd
- , naturalAndNot
- , naturalOr
- , naturalXor
- , naturalTestBit#
- , naturalBit#
- , naturalGcd
- , naturalLcm
- , naturalLog2#
- , naturalLogBaseWord#
- , naturalLogBase#
- , naturalPowMod
- , naturalSizeInBase#
- , Natural(..)
- , naturalBit
- , naturalCheck
- , naturalCheck#
- , naturalClearBit
- , naturalClearBit#
- , naturalCompare
- , naturalComplementBit
- , naturalComplementBit#
- , naturalEncodeDouble#
- , naturalEncodeFloat#
- , naturalEq
- , naturalEq#
- , naturalFromAddr
- , naturalFromAddr#
- , naturalFromBigNat#
- , naturalFromByteArray#
- , naturalFromWord
- , naturalFromWord#
- , naturalFromWord2#
- , naturalFromWordList
- , naturalGe
- , naturalGe#
- , naturalGt
- , naturalGt#
- , naturalIsOne
- , naturalIsPowerOf2#
- , naturalIsZero
- , naturalLe
- , naturalLe#
- , naturalLog2
- , naturalLogBase
- , naturalLogBaseWord
- , naturalLt
- , naturalLt#
- , naturalNe
- , naturalNe#
- , naturalNegate
- , naturalOne
- , naturalPopCount
- , naturalQuotRem
- , naturalSetBit
- , naturalSetBit#
- , naturalShiftL
- , naturalShiftR
- , naturalSignum
- , naturalSqr
- , naturalTestBit
- , naturalToAddr
- , naturalToAddr#
- , naturalToBigNat#
- , naturalToMutableByteArray#
- , naturalToWord
- , naturalToWordClamp
- , naturalToWordClamp#
- , naturalToWordMaybe#
- , naturalZero
+ , integerFromInt
+ , integerToNatural
+ , integerFromNatural
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToNaturalClamp
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToNaturalThrow
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToWord#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToInt#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToWord64#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToInt64#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerAdd
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerMul
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerSub
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerNegate
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerAbs
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerPopCount#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerQuot
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerRem
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerDiv
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerMod
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerDivMod#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerQuotRem#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerEncodeFloat#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerEncodeDouble#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerGcd
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLcm
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerAnd
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerOr
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerXor
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerComplement
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerBit#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerTestBit#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerShiftL#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerShiftR#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromWord#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromWord64#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromInt64#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerBit
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerCheck
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerCheck#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerCompare
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerDecodeDouble#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerDivMod
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerEncodeDouble
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerEq
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerEq#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromAddr
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromAddr#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromBigNat#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromBigNatNeg#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromBigNatSign#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromByteArray
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromByteArray#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromInt#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromWordList
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromWordNeg#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerFromWordSign#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerGcde
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerGcde#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerGe
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerGe#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerGt
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerGt#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerIsNegative
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerIsNegative#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerIsOne
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerIsPowerOf2#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerIsZero
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLe
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLe#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLog2
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLog2#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLogBase
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLogBase#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLogBaseWord
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLogBaseWord#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLt
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerLt#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerNe
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerNe#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerOne
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerPowMod#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerQuotRem
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerRecipMod#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerShiftL
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerShiftR
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerSignum
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerSignum#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerSizeInBase#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerSqr
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerTestBit
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToAddr
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToAddr#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToBigNatClamp#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToBigNatSign#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToMutableByteArray
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerToMutableByteArray#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ integerZero
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalToWord#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalPopCount#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalShiftR#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalShiftL#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalAdd
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalSub
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalSubThrow
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalSubUnsafe
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalMul
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalQuotRem#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalQuot
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalRem
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalAnd
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalAndNot
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalOr
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalXor
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalTestBit#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalBit#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalGcd
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLcm
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLog2#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLogBaseWord#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLogBase#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalPowMod
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalSizeInBase#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalBit
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalCheck
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalCheck#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalClearBit
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalClearBit#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalCompare
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalComplementBit
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalComplementBit#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalEncodeDouble#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalEncodeFloat#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalEq
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalEq#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalFromAddr
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalFromAddr#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalFromBigNat#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalFromByteArray#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalFromWord
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalFromWord#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalFromWord2#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalFromWordList
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalGe
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalGe#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalGt
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalGt#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalIsOne
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalIsPowerOf2#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalIsZero
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLe
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLe#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLog2
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLogBase
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLogBaseWord
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLt
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalLt#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalNe
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalNe#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalNegate
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalOne
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalPopCount
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalQuotRem
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalSetBit
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalSetBit#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalShiftL
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalShiftR
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalSignum
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalSqr
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalTestBit
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalToAddr
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalToAddr#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalToBigNat#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalToMutableByteArray#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalToWord
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalToWordClamp
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalToWordClamp#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalToWordMaybe#
+ , {-# DEPRECATED ["The internals of big numbers will be removed in base-XXX.", "Use ghc-bignum instead."] #-}
+ naturalZero
)
where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/90813e70496adc973b7ee7ad9bdd2cc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/90813e70496adc973b7ee7ad9bdd2cc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC
Commits:
bfff257c by Simon Peyton Jones at 2025-12-12T10:46:55+00:00
Wibbles
- - - - -
4 changed files:
- testsuite/tests/indexed-types/should_fail/T26176.stderr
- testsuite/tests/pmcheck/should_compile/T15753c.hs
- + testsuite/tests/pmcheck/should_compile/T22652.hs
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
testsuite/tests/indexed-types/should_fail/T26176.stderr
=====================================
@@ -1,9 +1,7 @@
-T26176.hs:18:7: error: [GHC-83865]
- • Couldn't match type ‘FA t’ with ‘5’
- Expected: SNat 5
- Actual: SNat (FA t)
- • In the expression: b
- In an equation for ‘a’: a = b
+T26176.hs:29:7: error: [GHC-64725]
+ • Cannot satisfy: FA t <= FB t
+ • In the expression: bar @t
+ In an equation for ‘x’: x = bar @t
In an equation for ‘foo’:
foo
= undefined
@@ -14,30 +12,4 @@ T26176.hs:18:7: error: [GHC-83865]
b = undefined
c :: SNat 3
...
- • Relevant bindings include
- b :: SNat (FA t) (bound at T26176.hs:21:3)
- d :: SNat (FB t) (bound at T26176.hs:27:3)
- x :: p0 t (bound at T26176.hs:29:3)
- foo :: p t (bound at T26176.hs:15:1)
-
-T26176.hs:24:7: error: [GHC-83865]
- • Couldn't match type ‘FB t’ with ‘3’
- Expected: SNat 3
- Actual: SNat (FB t)
- • In the expression: d
- In an equation for ‘c’: c = d
- In an equation for ‘foo’:
- foo
- = undefined
- where
- a :: SNat 5
- a = b
- b :: SNat (FA t)
- b = undefined
- c :: SNat 3
- ...
- • Relevant bindings include
- d :: SNat (FB t) (bound at T26176.hs:27:3)
- x :: p0 t (bound at T26176.hs:29:3)
- foo :: p t (bound at T26176.hs:15:1)
=====================================
testsuite/tests/pmcheck/should_compile/T15753c.hs
=====================================
@@ -34,6 +34,22 @@ type family F (u1 :: ()) (u2 :: ()) :: Type where
type family Case (u :: ()) :: Type where
Case '() = Int
+---------------------------------------
+-- The checker can (now, Dec 25) see that (F u1 u2 ~ Char) is
+-- unsatisfiable, so the empty pattern match is fine
+g1a :: F u1 u2 :~: Char -> SUnit u1 -> SUnit u2 -> Void
+g1a r _ _ = case r of {}
+
+{- Why [G] F u1 u2 ~ Char is unsatisfiable
+
+[G] F u1 u2 ~ Char =>rewrite [G] If (IsUnit u1) (Case u2) Int ~ Char
+ =>(fundep) [W] IsUnit u1 ~ True
+ [W] Case u2 ~ Char <<-- insoluble: no relevant eqns
+-}
+
+---------------------------------------
+-- This older test matches on Refl (which is unsatisfiable)
+-- but we now get complaints from inside
g1 :: F u1 u2 :~: Char
-> SUnit u1 -> SUnit u2
-> Void
@@ -41,21 +57,7 @@ g1 Refl su1 su2
| STrue <- sIsUnit su1
= case su2 of {}
--- g1a :: F u1 u2 :~: Char -> SUnit u1 -> SUnit u2 -> Void
--- g1a r _ _ = case r of {} -- Why does this complain about missing Refl
-{- [G] F u1 u2 ~ Char
- [W] SBool (IsUnit u1) ~ SBool True
-==>
- [W] IsUnit u1 ~ True
-==> fundep
- u1 ~ ()
-
-
-[G] F u1 u2 ~ Char =>(fundep) [W] If (IsUnit u1) (Case u2) Int ~ Char
- =>(fundep) [W] IsUnit u1 ~ True
- [W] Case u2 ~ Char <<-- insoluble: no relevant eqns
--}
g2 :: F u1 u2 :~: Char
-> SUnit u1 -> SUnit u2
@@ -64,4 +66,3 @@ g2 Refl su1 su2
= case sIsUnit su1 of
STrue ->
case su2 of {}
-
=====================================
testsuite/tests/pmcheck/should_compile/T22652.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE DataKinds, TypeFamilies, GADTs #-}
+{-# OPTIONS_GHC -Wincomplete-patterns -Werror #-}
+
+module T22652 where
+
+data T = Z | S
+
+data ST n where
+ SZ :: ST Z
+ SS :: ST S
+
+type family F n where
+ F Z = Z
+ F S = Z
+
+f :: F m ~ n => ST m -> ST n -> ()
+f _ SZ = ()
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -179,3 +179,4 @@ test('T24824', normal, compile, ['-package ghc -Wincomplete-record-selectors'])
test('T24891', normal, compile, ['-Wincomplete-record-selectors'])
test('T25257', normal, compile, [overlapping_incomplete])
test('T24845', [], compile, [overlapping_incomplete])
+test('T22652', [], compile, [overlapping_incomplete])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bfff257ca6d35572eec23ae84a8cb87…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bfff257ca6d35572eec23ae84a8cb87…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ci-note-treeless] 3 commits: compiler: remove unused CPP code in foreign stub
by Magnus (＠MangoIV) 12 Dec '25
by Magnus (＠MangoIV) 12 Dec '25
12 Dec '25
Magnus pushed to branch wip/ci-note-treeless at Glasgow Haskell Compiler / GHC
Commits:
d99f8326 by Cheng Shao at 2025-12-11T19:14:18-05:00
compiler: remove unused CPP code in foreign stub
This patch removes unused CPP code in the generated foreign stub:
- `#define IN_STG_CODE 0` is not needed, since `Rts.h` already
includes this definition
- The `if defined(__cplusplus)` code paths are not needed in the `.c`
file, since we don't generate C++ stubs and don't include C++
headers in our stubs. But it still needs to be present in the `.h`
header since it might be later included into C++ source files.
- - - - -
46c9746f by Cheng Shao at 2025-12-11T19:14:57-05:00
configure: bump LlvmMaxVersion to 22
This commit bumps LlvmMaxVersion to 22; 21.x releases have been
available since Aug 26th, 2025 and there's no regressions with 21.x so
far. This bump is also required for updating fedora image to 43.
- - - - -
495389d3 by Cheng Shao at 2025-12-12T09:01:59+00:00
ci: use treeless fetch for perf notes
This patch improves the ci logic for fetching perf notes by using
treeless fetch
(https://github.blog/open-source/git/get-up-to-speed-with-partial-clone-and-…)
to avoid downloading all blobs of the perf notes repo at once, and
only fetch the actually required blobs on-demand when needed. This
makes the initial `test-metrics.sh pull` operation much faster, and
also more robust, since we are seeing an increasing rate of 504 errors
in CI when fetching all perf notes at once, which is a major source of
CI flakiness at this point.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
3 changed files:
- .gitlab/test-metrics.sh
- compiler/GHC/Driver/CodeOutput.hs
- configure.ac
Changes:
=====================================
.gitlab/test-metrics.sh
=====================================
@@ -17,12 +17,14 @@ fail() {
function pull() {
local ref="refs/notes/$REF"
- # 2023-10-04: `git fetch` started failing, first on Darwin in CI and then on
- # Linux locally, both using git version 2.40.1. See #24055. One workaround is
- # to set a larger http.postBuffer, although this is definitely a workaround.
- # The default should work just fine. The error could be in git, GitLab, or
- # perhaps the networking tube (including all proxies etc) between the two.
- run git -c http.postBuffer=2097152 fetch -f "$NOTES_ORIGIN" "$ref:$ref"
+
+ # Fetch performance notes from a dedicated promisor remote using a
+ # treeless filter, so that individual note blobs are fetched lazily
+ # as needed.
+ git remote add perf-notes "$NOTES_ORIGIN" || true
+ git config fetch.recurseSubmodules false
+ git config remote.perf-notes.partialclonefilter tree:0
+ run git fetch --force perf-notes "$ref:$ref"
echo "perf notes ref $ref is $(git rev-parse $ref)"
}
@@ -81,4 +83,3 @@ case $1 in
pull) pull ;;
*) fail "Invalid mode $1" ;;
esac
-
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -329,15 +329,8 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
stub_c_file_exists
<- outputForeignStubs_help stub_c stub_c_output_w
- ("#define IN_STG_CODE 0\n" ++
- "#include <Rts.h>\n" ++
- rts_includes ++
- ffi_includes ++
- cplusplus_hdr)
- cplusplus_ftr
- -- We're adding the default hc_header to the stub file, but this
- -- isn't really HC code, so we need to define IN_STG_CODE==0 to
- -- avoid the register variables etc. being enabled.
+ (rts_includes ++
+ ffi_includes) ""
return (stub_h_file_exists, if stub_c_file_exists
then Just stub_c
=====================================
configure.ac
=====================================
@@ -526,7 +526,7 @@ AC_SUBST(InstallNameToolCmd)
# versions of LLVM simultaneously, but that stopped working around
# 3.5/3.6 release of LLVM.
LlvmMinVersion=13 # inclusive
-LlvmMaxVersion=21 # not inclusive
+LlvmMaxVersion=22 # not inclusive
AC_SUBST([LlvmMinVersion])
AC_SUBST([LlvmMaxVersion])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/505caf1d6a41fe339dfec41c9e81a7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/505caf1d6a41fe339dfec41c9e81a7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 11 commits: compiler: remove unused CPP code in foreign stub
by Marge Bot (＠marge-bot) 12 Dec '25
by Marge Bot (＠marge-bot) 12 Dec '25
12 Dec '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
d99f8326 by Cheng Shao at 2025-12-11T19:14:18-05:00
compiler: remove unused CPP code in foreign stub
This patch removes unused CPP code in the generated foreign stub:
- `#define IN_STG_CODE 0` is not needed, since `Rts.h` already
includes this definition
- The `if defined(__cplusplus)` code paths are not needed in the `.c`
file, since we don't generate C++ stubs and don't include C++
headers in our stubs. But it still needs to be present in the `.h`
header since it might be later included into C++ source files.
- - - - -
46c9746f by Cheng Shao at 2025-12-11T19:14:57-05:00
configure: bump LlvmMaxVersion to 22
This commit bumps LlvmMaxVersion to 22; 21.x releases have been
available since Aug 26th, 2025 and there's no regressions with 21.x so
far. This bump is also required for updating fedora image to 43.
- - - - -
96fce8d0 by Cheng Shao at 2025-12-12T01:17:51+01:00
hadrian: add support for building with UndefinedBehaviorSanitizer
This patch adds a +ubsan flavour transformer to hadrian to build all
stage1+ C/C++ code with UndefinedBehaviorSanitizer. This is
particularly useful to catch potential undefined behavior in the RTS
codebase.
- - - - -
f7a06d8c by Cheng Shao at 2025-12-12T01:17:51+01:00
ci: update alpine/fedora & add ubsan job
This patch updates alpine image to 3.23, fedora image to 43, and adds
a `x86_64-linux-fedora43-validate+debug_info+ubsan` job that's run in
validate/nightly pipelines to catch undefined behavior in the RTS
codebase.
- - - - -
2ccd11ca by Cheng Shao at 2025-12-12T01:17:51+01:00
rts: fix zero-length VLA undefined behavior in interpretBCO
This commit fixes a zero-length VLA undefined behavior in interpretBCO, caught by UBSan:
```
+rts/Interpreter.c:3133:19: runtime variable length array bound evaluates to non-positive value 0
```
- - - - -
4156ed19 by Cheng Shao at 2025-12-12T01:17:51+01:00
rts: fix unaligned ReadSpB in interpretBCO
This commit fixes unaligned ReadSpB in interpretBCO, caught by UBSan:
```
+rts/Interpreter.c:2174:64: runtime load of misaligned address 0x004202059dd1 for type 'StgWord', which requires 8 byte alignment
```
To perform proper unaligned read, we define StgUnalignedWord as a type
alias of StgWord with aligned(1) attribute, and load StgUnalignedWord
instead of StgWord in ReadSpB, so the C compiler is aware that we're
not loading with natural alignment.
- - - - -
fef89fb9 by Cheng Shao at 2025-12-12T01:17:51+01:00
rts: fix signed integer overflow in subword arithmetic in interpretBCO
This commit fixes signed integer overflow in subword arithmetic in
interpretBCO, see added note for detailed explanation.
- - - - -
2a5bc4ba by sheaf at 2025-12-12T02:56:17-05:00
X86 CodeGen: fix assign_eax_sse_regs
We must set %al to the number of SSE2 registers that contain arguments
(in case we are dealing with a varargs function). The logic for counting
how many arguments reside in SSE2 registers was incorrect, as it used
'isFloatFormat', which incorrectly ignores vector registers.
We now instead do case analysis on the register class:
is_sse_reg r =
case targetClassOfReg platform r of
RcFloatOrVector -> True
RcInteger -> False
This change is necessary to prevent segfaults in T20030_test1j, because
subsequent commits change the format calculations, resulting in vector
formats more often.
- - - - -
feb9b195 by sheaf at 2025-12-12T02:56:17-05:00
Liveness analysis: consider register formats
This commit updates the register allocator to be a bit more careful in
situations in which a single register is used at multiple different
formats, e.g. when xmm1 is used both to store a Double# and a DoubleX2#.
This is done by introducing the 'Regs' newtype around 'UniqSet RegWithFormat',
for which the combining operations take the larger of the two formats
instead of overriding the format.
Operations on 'Regs' are defined in 'GHC.CmmToAsm.Reg.Regs'. There is
a modest compile-time cost for the additional overhead for tracking
register formats, which causes the metric increases of this commit.
The subtle aspects of the implementation are outlined in
Note [Register formats in liveness analysis] in GHC.CmmToAsm.Reg.Liveness.
Fixes #26411 #26611
-------------------------
Metric Increase:
T12707
T26425
T3294
-------------------------
- - - - -
36ee30f3 by sheaf at 2025-12-12T02:56:17-05:00
Register allocator: reload at same format as spill
This commit ensures that if we spill a register onto the stack at a
given format, we then always reload the register at this same format.
This ensures we don't end up in a situation where we spill F64x2 but end
up only reloading the lower F64. This first reload would make us believe
the whole data is in a register, thus silently losing the upper 64 bits
of the spilled register's contents.
Fixes #26526
- - - - -
02c25c49 by sheaf at 2025-12-12T02:56:17-05:00
Register allocation: writes redefine format
As explained in Note [Allocated register formats] in GHC.CmmToAsm.Reg.Linear,
we consider all writes to redefine the format of the register.
This ensures that in a situation such as
movsd .Ln6m(%rip),%v1
shufpd $0,%v1,%v1
we properly consider the broadcast operation to change the format of %v1
from F64 to F64x2.
This completes the fix to #26411 (test in T26411b).
- - - - -
35 changed files:
- .gitlab-ci.yml
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- compiler/GHC/CmmToAsm/Reg/Graph.hs
- compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs
- compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
- compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
- compiler/GHC/CmmToAsm/Reg/Liveness.hs
- + compiler/GHC/CmmToAsm/Reg/Regs.hs
- compiler/GHC/CmmToAsm/Reg/Target.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Unique/Set.hs
- compiler/ghc.cabal.in
- configure.ac
- hadrian/doc/flavours.md
- hadrian/src/Flavour.hs
- + rts/.ubsan-suppressions
- rts/Interpreter.c
- rts/include/stg/Types.h
- rts/rts.cabal
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- + testsuite/tests/simd/should_run/T26411.hs
- + testsuite/tests/simd/should_run/T26411.stdout
- + testsuite/tests/simd/should_run/T26411b.hs
- + testsuite/tests/simd/should_run/T26411b.stdout
- testsuite/tests/simd/should_run/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2f18fba74b3878fcd0c4ae352611ed…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2f18fba74b3878fcd0c4ae352611ed…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
12 Dec '25
Cheng Shao pushed new branch wip/terrorjack/asan at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/terrorjack/asan
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/torsten.schmits/mwb/perf-tuning
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
12 Dec '25
Torsten Schmits pushed new branch wip/torsten.schmits/mwb/perf-tuning at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/torsten.schmits/mwb/perf-tuni…
You're receiving this email because of your account on gitlab.haskell.org.
1
0