[Git][ghc/ghc][master] 2 commits: Add hints for unsolved HasField constraints
by Marge Bot (＠marge-bot) 27 Oct '25
by Marge Bot (＠marge-bot) 27 Oct '25
27 Oct '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
fbdc623a by sheaf at 2025-10-26T18:23:52-04:00
Add hints for unsolved HasField constraints
This commit adds hints and explanations for unsolved 'HasField'
constraints.
GHC will now provide additional explanations for an unsolved constraint
of the form 'HasField fld_name rec_ty fld_ty'; the details are laid out in
Note [Error messages for unsolved HasField constraints], but briefly:
1. Provide similar name suggestions (e.g. mis-spelled field name)
and import suggestions (record field not in scope).
These result in actionable 'GhcHints', which is helpful to provide
code actions in HLS.
2. Explain why GHC did not solve the constraint, e.g.:
- 'fld_name' is not a string literal (e.g. a type variable)
- 'rec_ty' is a TyCon without any fields, e.g. 'Int' or 'Bool'.
- 'fld_ty' contains existentials variables or foralls.
- The record field is a pattern synonym field (GHC does not generate
HasField instances for those).
- 'HasField' is a custom 'TyCon', not actually the built-in
'HasField' typeclass from 'GHC.Records'.
On the way, we slightly refactor the mechanisms for import suggestions
in GHC.Rename.Unbound. This is to account for the fact that, for
'HasField', we don't care whether the field is imported qualified or
unqualified. 'importSuggestions' was refactored, we now have
'sameQualImportSuggestions' and 'anyQualImportSuggestions'.
Fixes #18776 #22382 #26480
- - - - -
99d5707f by sheaf at 2025-10-26T18:23:52-04:00
Rename PatSyn MatchContext to PatSynCtx to avoid punning
- - - - -
29 changed files:
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480.stderr
- + testsuite/tests/overloadedrecflds/should_fail/T26480_aux1.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480_aux2.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480b.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr
- testsuite/tests/overloadedrecflds/should_fail/all.T
- testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr
- testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
- testsuite/tests/rename/should_fail/T19843h.stderr
Changes:
=====================================
compiler/GHC/Core/ConLike.hs
=====================================
@@ -26,6 +26,8 @@ module GHC.Core.ConLike (
, conLikeFieldType
, conLikeIsInfix
, conLikeHasBuilder
+
+ , isExistentialRecordField
) where
import GHC.Prelude
@@ -35,7 +37,7 @@ import GHC.Core.Multiplicity
import GHC.Core.PatSyn
import GHC.Core.TyCo.Rep (Type, ThetaType)
import GHC.Core.TyCon (tyConDataCons)
-import GHC.Core.Type(mkTyConApp)
+import GHC.Core.Type(mkTyConApp, tyCoVarsOfType)
import GHC.Types.Unique
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -43,6 +45,7 @@ import GHC.Types.Basic
import GHC.Types.GREInfo
import GHC.Types.Var
+import GHC.Types.Var.Set
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -239,3 +242,23 @@ conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
conLikeIsInfix :: ConLike -> Bool
conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps
+
+-- | Is this record field a naughty record field due to the presence of
+-- existential type variables?
+--
+-- Different from 'isNaughtyRecordSelector' because the latter is also true
+-- in the presence of @-XNoFieldSelectors@.
+--
+-- See Note [Naughty record selectors] in GHC.Tc.TyCl.Utils.
+isExistentialRecordField :: Type -> ConLike -> Bool
+isExistentialRecordField field_ty con =
+ case con of
+ RealDataCon {} -> not $ field_ty_tvs `subVarSet` res_ty_tvs
+ PatSynCon {} -> not $ field_ty_tvs `subVarSet` mkVarSet univ_tvs
+ -- In the PatSynCon case, the selector type is (data_ty -> field_ty), but
+ -- fvs(data_ty) are all universals (see Note [Pattern synonym result type] in
+ -- GHC.Core.PatSyn, so no need to check them.
+ where
+ field_ty_tvs = tyCoVarsOfType field_ty
+ res_ty_tvs = tyCoVarsOfType data_ty
+ (univ_tvs, _, _, _, _, _, data_ty) = conLikeFullSig con
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1898,7 +1898,7 @@ matchSeparator PatBindRhs = text "="
matchSeparator PatBindGuards = text "="
matchSeparator StmtCtxt{} = text "<-"
matchSeparator RecUpd = text "=" -- This can be printed by the pattern
-matchSeparator PatSyn = text "<-" -- match checker trace
+matchSeparator PatSynCtx = text "<-" -- match checker trace
matchSeparator LazyPatCtx = panic "unused"
matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
@@ -2494,7 +2494,7 @@ instance Outputable fn => Outputable (HsMatchContext fn) where
ppr (StmtCtxt _) = text "StmtCtxt _"
ppr ThPatSplice = text "ThPatSplice"
ppr ThPatQuote = text "ThPatQuote"
- ppr PatSyn = text "PatSyn"
+ ppr PatSynCtx = text "PatSynCtx"
ppr LazyPatCtx = text "LazyPatCtx"
instance Outputable HsLamVariant where
@@ -2538,7 +2538,7 @@ matchContextErrString RecUpd = text "record update"
matchContextErrString (ArrowMatchCtxt c) = matchArrowContextErrString c
matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
-matchContextErrString PatSyn = text "pattern synonym"
+matchContextErrString PatSynCtx = text "pattern synonym"
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
@@ -2613,7 +2613,7 @@ pprMatchContextNoun PatBindGuards = text "pattern binding guards"
pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c
pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
$$ pprAStmtContext ctxt
-pprMatchContextNoun PatSyn = text "pattern synonym declaration"
+pprMatchContextNoun PatSynCtx = text "pattern synonym declaration"
pprMatchContextNoun LazyPatCtx = text "irrefutable pattern"
pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc
=====================================
compiler/GHC/HsToCore/Pmc/Utils.hs
=====================================
@@ -93,7 +93,7 @@ exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFla
exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
exhaustiveWarningFlag LazyPatCtx = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag ThPatSplice = Nothing
-exhaustiveWarningFlag PatSyn = Nothing
+exhaustiveWarningFlag PatSynCtx = Nothing
exhaustiveWarningFlag ThPatQuote = Nothing
-- Don't warn about incomplete patterns in list comprehensions, pattern guards
-- etc. They are often *supposed* to be incomplete
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -763,7 +763,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
; let scoped_tvs = sig_fn name
; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $
- rnPat PatSyn pat $ \pat' ->
+ rnPat PatSynCtx pat $ \pat' ->
-- We check the 'RdrName's instead of the 'Name's
-- so that the binding locations are reported
-- from the left-hand side
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -2453,8 +2453,8 @@ badImportItemErr iface decl_spec ie sub avails = do
-- Only keep imported items, and set the "HowInScope" to
-- "Nothing" to avoid printing "imported from..." in the suggestion
-- error message.
- imported_item (SimilarRdrName rdr_name (Just (ImportedBy {})))
- = Just (SimilarRdrName rdr_name Nothing)
+ imported_item (SimilarRdrName rdr_name gre (Just (ImportedBy {})))
+ = Just (SimilarRdrName rdr_name gre Nothing)
imported_item _ = Nothing
checkIfDataCon = checkIfAvailMatches isDataConName
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -18,6 +18,7 @@ module GHC.Rename.Unbound
, unknownNameSuggestionsMessage
, similarNameSuggestions
, fieldSelectorSuggestions
+ , anyQualImportSuggestions
, WhatLooking(..)
, WhereLooking(..)
, LookingFor(..)
@@ -215,7 +216,7 @@ unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env
, map (ImportSuggestion $ rdrNameOcc tried_rdr_name) imp_suggs
, extensionSuggestions tried_rdr_name
, fieldSelectorSuggestions global_env tried_rdr_name ]
- (imp_errs, imp_suggs) = importSuggestions looking_for hpt curr_mod imports tried_rdr_name
+ (imp_errs, imp_suggs) = sameQualImportSuggestions looking_for hpt curr_mod imports tried_rdr_name
if_ne :: (NonEmpty a -> b) -> [a] -> [b]
if_ne _ [] = []
@@ -242,7 +243,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
all_possibilities :: [(String, SimilarName)]
all_possibilities = case what_look of
WL_None -> []
- _ -> [ (showPpr dflags r, SimilarRdrName r (Just $ LocallyBoundAt loc))
+ _ -> [ (showPpr dflags r, SimilarRdrName r Nothing (Just $ LocallyBoundAt loc))
| (r,loc) <- local_possibilities local_env ]
++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
@@ -273,7 +274,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)]
global_possibilities global_env
- | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual (Just how))
+ | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual (Just gre) (Just how))
| gre <- globalRdrEnvElts global_env
, isGreOk looking_for gre
, let occ = greOccName gre
@@ -288,7 +289,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
rdr_unqual = mkRdrUnqual occ
, is_relevant occ
, sim <- case (unquals_in_scope gre, quals_only gre) of
- (how:_, _) -> [ SimilarRdrName rdr_unqual (Just how) ]
+ (how:_, _) -> [ SimilarRdrName rdr_unqual (Just gre) (Just how) ]
([], pr:_) -> [ pr ] -- See Note [Only-quals]
([], []) -> [] ]
@@ -316,45 +317,74 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
quals_only :: GlobalRdrElt -> [SimilarName]
-- Ones for which *only* the qualified version is in scope
quals_only (gre@GRE { gre_imp = is })
- = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (Just $ ImportedBy ispec))
+ = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (Just gre) (Just $ ImportedBy ispec))
| i <- bagToList is, let ispec = is_decl i, is_qual ispec ]
+-- | Provide import suggestions, without filtering by module qualification.
+-- Used to suggest imports for 'HasField', which doesn't care about whether a
+-- name is imported qualified or unqualified.
+--
+-- For example:
+--
+-- > import M1 () -- M1 exports fld1
+-- > import qualified M2 hiding ( fld2 )
+-- > x r = r.fld1 -- suggest adding 'fld1' to M1 import
+-- > y r = getField @"fld2" r -- suggest unhiding 'fld' from M2 import
+anyQualImportSuggestions :: LookingFor -> LookupGRE GREInfo -> TcM [ImportSuggestion]
+anyQualImportSuggestions looking_for lookup_gre =
+ do { imp_info <- getImports
+ ; let interesting_imports = interestingImports imp_info (const True)
+ ; return $
+ importSuggestions_ looking_for interesting_imports lookup_gre
+ }
--- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope.
-importSuggestions :: LookingFor
- -> InteractiveContext -> Module
- -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion])
-importSuggestions looking_for ic currMod imports rdr_name
- | WL_LocalOnly <- lf_where looking_for = ([], [])
- | WL_LocalTop <- lf_where looking_for = ([], [])
+-- | The given 'RdrName' is not in scope. Try to find out why that is by looking
+-- at the import list, to suggest e.g. changing the import list somehow.
+--
+-- For example:
+--
+-- > import qualified M1 hiding ( blah1 )
+-- > x = M1.blah -- suggest unhiding blah1
+-- > y = XX.blah1 -- import error: no imports provide the XX qualification prefix
+sameQualImportSuggestions
+ :: LookingFor
+ -> InteractiveContext
+ -> Module
+ -> ImportAvails
+ -> RdrName
+ -> ([ImportError], [ImportSuggestion])
+sameQualImportSuggestions looking_for ic currMod imports rdr_name
| not (isQual rdr_name || isUnqual rdr_name) = ([], [])
- | Just name <- mod_name
- , show_not_imported_line name
- = ([MissingModule name], [])
+ | Just rdr_mod_name <- mb_rdr_mod_name
+ , show_not_imported_line rdr_mod_name
+ = ([MissingModule rdr_mod_name], [])
| is_qualified
- , null helpful_imports
+ , null import_suggs
, (mod : mods) <- map fst interesting_imports
= ([ModulesDoNotExport (mod :| mods) (lf_which looking_for) occ_name], [])
- | mod : mods <- helpful_imports_non_hiding
- = ([], [CouldImportFrom (mod :| mods)])
- | mod : mods <- helpful_imports_hiding
- = ([], [CouldUnhideFrom (mod :| mods)])
| otherwise
- = ([], [])
- where
+ = ([], import_suggs)
+ where
+
+ interesting_imports = interestingImports imports right_qual_import
+
+ import_suggs =
+ importSuggestions_ looking_for interesting_imports $
+ (LookupOccName (rdrNameOcc rdr_name) $ RelevantGREsFOS WantNormal)
+
is_qualified = isQual rdr_name
- (mod_name, occ_name) = case rdr_name of
+ (mb_rdr_mod_name, occ_name) = case rdr_name of
Unqual occ_name -> (Nothing, occ_name)
Qual mod_name occ_name -> (Just mod_name, occ_name)
- _ -> panic "importSuggestions: dead code"
-
+ _ -> panic "sameQualImportSuggestions: dead code"
- -- What import statements provide "Mod" at all
- -- or, if this is an unqualified name, are not qualified imports
- interesting_imports = [ (mod, imp)
- | (mod, mod_imports) <- M.toList (imp_mods imports)
- , Just imp <- return $ pick (importedByUser mod_imports)
- ]
+ -- See Note [When to show/hide the module-not-imported line]
+ show_not_imported_line :: ModuleName -> Bool -- #15611
+ show_not_imported_line modnam
+ | not (null interactive_imports) = False -- 1 (interactive context)
+ | not (null interesting_imports) = False -- 1 (normal module import)
+ | moduleName currMod == modnam = False -- 2
+ | otherwise = True
-- Choose the imports from the interactive context which might have provided
-- a module.
@@ -362,18 +392,52 @@ importSuggestions looking_for ic currMod imports rdr_name
filter pick_interactive (ic_imports ic)
pick_interactive :: InteractiveImport -> Bool
- pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True
- | mod_name == fmap unLoc (ideclAs d) = True
- pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True
+ pick_interactive (IIDecl d) | mb_rdr_mod_name == Just (unLoc (ideclName d)) = True
+ | mb_rdr_mod_name == fmap unLoc (ideclAs d) = True
+ pick_interactive (IIModule m) | mb_rdr_mod_name == Just (moduleName m) = True
pick_interactive _ = False
+ right_qual_import imv =
+ case mb_rdr_mod_name of
+ -- Qual RdrName: only want qualified imports with the same module name
+ Just rdr_mod_name -> imv_name imv == rdr_mod_name
+ -- UnQual RdrName: import must be unqualified
+ Nothing -> not (imv_qualified imv)
+
+-- | What import statements are relevant?
+--
+-- - If we are looking for a qualified name @Mod.blah@, which imports provide @Mod@ at all,
+-- - If we are looking for an unqualified name, which imports are themselves unqualified.
+interestingImports :: ImportAvails -> (ImportedModsVal -> Bool) -> [(Module, ImportedModsVal)]
+interestingImports imports ok_mod_name =
+ [ (mod, imp)
+ | (mod, mod_imports) <- M.toList (imp_mods imports)
+ , Just imp <- return $ pick (importedByUser mod_imports)
+ ]
+
+ where
-- We want to keep only one for each original module; preferably one with an
-- explicit import list (for no particularly good reason)
pick :: [ImportedModsVal] -> Maybe ImportedModsVal
- pick = listToMaybe . sortBy cmp . filter select
- where select imv = case mod_name of Just name -> imv_name imv == name
- Nothing -> not (imv_qualified imv)
- cmp = on compare imv_is_hiding S.<> on SrcLoc.leftmost_smallest imv_span
+ pick = listToMaybe . sortBy cmp . filter ok_mod_name
+ where
+ cmp = on compare imv_is_hiding S.<> on SrcLoc.leftmost_smallest imv_span
+
+importSuggestions_
+ :: LookingFor
+ -> [(Module, ImportedModsVal)]
+ -> LookupGRE GREInfo
+ -> [ImportSuggestion]
+importSuggestions_ looking_for interesting_imports lookup_gre
+ | WL_LocalOnly <- lf_where looking_for = []
+ | WL_LocalTop <- lf_where looking_for = []
+ | mod : mods <- helpful_imports_non_hiding
+ = [CouldImportFrom (mod :| mods)]
+ | mod : mods <- helpful_imports_hiding
+ = [CouldUnhideFrom (mod :| mods)]
+ | otherwise
+ = []
+ where
-- Which of these would export a 'foo'
-- (all of these are restricted imports, because if they were not, we
@@ -382,21 +446,13 @@ importSuggestions looking_for ic currMod imports rdr_name
where helpful (_,imv)
= any (isGreOk looking_for) $
lookupGRE (imv_all_exports imv)
- (LookupOccName occ_name $ RelevantGREsFOS WantNormal)
+ lookup_gre
-- Which of these do that because of an explicit hiding list resp. an
-- explicit import list
(helpful_imports_hiding, helpful_imports_non_hiding)
= partition (imv_is_hiding . snd) helpful_imports
- -- See Note [When to show/hide the module-not-imported line]
- show_not_imported_line :: ModuleName -> Bool -- #15611
- show_not_imported_line modnam
- | not (null interactive_imports) = False -- 1 (interactive context)
- | not (null interesting_imports) = False -- 1 (normal module import)
- | moduleName currMod == modnam = False -- 2
- | otherwise = True
-
extensionSuggestions :: RdrName -> [GhcHint]
extensionSuggestions rdrName
| rdrName == mkUnqual varName (fsLit "mdo") ||
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -17,6 +17,8 @@ module GHC.Tc.Errors(
import GHC.Prelude
+import GHC.Builtin.Names (hasFieldClassName)
+
import GHC.Driver.Env (hsc_units)
import GHC.Driver.DynFlags
import GHC.Driver.Ppr
@@ -31,6 +33,7 @@ import GHC.Tc.Errors.Ppr
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc
import GHC.Tc.Utils.TcMType
+import GHC.Tc.Utils.Env (tcLookupId, tcLookupDataCon)
import GHC.Tc.Zonk.Type
import GHC.Tc.Utils.TcType
import GHC.Tc.Zonk.TcType
@@ -43,6 +46,7 @@ import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConf
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.Id
+import GHC.Types.Id.Info (IdDetails(..), RecSelParent (..))
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
@@ -50,13 +54,18 @@ import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Error
+import GHC.Types.Hint (SimilarName (..))
import qualified GHC.Types.Unique.Map as UM
+import GHC.Types.Unique.Set (nonDetEltsUniqSet)
import GHC.Unit.Module
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Core.PatSyn (PatSyn)
import GHC.Core.Predicate
import GHC.Core.Type
+import GHC.Core.Class (className)
+import GHC.Core.ConLike (isExistentialRecordField, ConLike (..))
import GHC.Core.Coercion
import GHC.Core.TyCo.Ppr ( pprTyVars )
import GHC.Core.TyCo.Tidy
@@ -75,13 +84,18 @@ import GHC.Data.List.SetOps ( equivClasses, nubOrdBy )
import GHC.Data.Maybe
import qualified GHC.Data.Strict as Strict
+
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
import Control.Monad ( unless, when, foldM, forM_ )
+import Data.Bifunctor ( bimap )
import Data.Foldable ( toList )
import Data.Function ( on )
import Data.List ( partition, union, sort, sortBy )
import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
import qualified Data.List.NonEmpty as NE
import Data.Ord ( comparing )
+import Data.Either (partitionEithers)
{-
************************************************************************
@@ -1470,8 +1484,8 @@ coercion.
mkIrredErr :: SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport
mkIrredErr ctxt items
= do { (ctxt, binds, item1) <- relevantBindings True ctxt item1
- ; let msg = important ctxt $ mkPlainMismatchMsg $
- CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing
+ ; couldNotDeduceErr <- mkCouldNotDeduceErr (getUserGivens ctxt) (item1 :| others) Nothing
+ ; let msg = important ctxt $ mkPlainMismatchMsg couldNotDeduceErr
; return $ add_relevant_bindings binds msg }
where
item1:|others = tryFilter (not . ei_suppress) items
@@ -1851,6 +1865,7 @@ reportEqErr :: SolverReportErrCtxt
-> TcM TcSolverReportMsg
reportEqErr ctxt item ty1 ty2
= do
+ mismatch <- misMatchOrCND ctxt item ty1 ty2
mb_coercible_info <- if errorItemEqRel item == ReprEq
then coercible_msg ty1 ty2
else return Nothing
@@ -1862,7 +1877,6 @@ reportEqErr ctxt item ty1 ty2
, mismatchAmbiguityInfo = eqInfos
, mismatchCoercibleInfo = mb_coercible_info }
where
- mismatch = misMatchOrCND ctxt item ty1 ty2
eqInfos = eqInfoMsgs ty1 ty2
coercible_msg :: TcType -> TcType -> TcM (Maybe CoercibleMsg)
@@ -1894,6 +1908,7 @@ mkTyVarEqErr' ctxt item tv1 ty2
-- try it before anything more complicated.
| check_eq_result `cterHasProblem` cteImpredicative
= do
+ headline_msg <- misMatchOrCND ctxt item ty1 ty2
tyvar_eq_info <- extraTyVarEqInfo (tv1, Nothing) ty2
let
poly_msg = CannotUnifyWithPolytype item tv1 ty2 mb_tv_info
@@ -1917,6 +1932,7 @@ mkTyVarEqErr' ctxt item tv1 ty2
|| errorItemEqRel item == ReprEq
-- The cases below don't really apply to ReprEq (except occurs check)
= do
+ headline_msg <- misMatchOrCND ctxt item ty1 ty2
tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2
reason <- if errorItemEqRel item == ReprEq
then RepresentationalEq tv_extra <$> coercible_msg ty1 ty2
@@ -1933,23 +1949,24 @@ mkTyVarEqErr' ctxt item tv1 ty2
--
-- Use tyCoVarsOfType because it might have begun as the canonical
-- constraint (Dual (Dual a)) ~ a, and been swizzled by mkEqnErr_help
- = let ambiguity_infos = eqInfoMsgs ty1 ty2
+ = do headline_msg <- misMatchOrCND ctxt item ty1 ty2
+ let ambiguity_infos = eqInfoMsgs ty1 ty2
- interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
- filter isTyVar $
- fvVarList $
- tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
+ interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
+ filter isTyVar $
+ fvVarList $
+ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
- occurs_err =
- OccursCheck
- { occursCheckInterestingTyVars = interesting_tyvars
- , occursCheckAmbiguityInfos = ambiguity_infos }
- main_msg =
- CannotUnifyVariable
- { mismatchMsg = headline_msg
- , cannotUnifyReason = occurs_err }
+ occurs_err =
+ OccursCheck
+ { occursCheckInterestingTyVars = interesting_tyvars
+ , occursCheckAmbiguityInfos = ambiguity_infos }
+ main_msg =
+ CannotUnifyVariable
+ { mismatchMsg = headline_msg
+ , cannotUnifyReason = occurs_err }
- in return main_msg
+ return main_msg
-- If the immediately-enclosing implication has 'tv' a skolem, and
-- we know by now its an InferSkol kind of skolem, then presumably
@@ -2005,7 +2022,6 @@ mkTyVarEqErr' ctxt item tv1 ty2
-- Consider an ambiguous top-level constraint (a ~ F a)
-- Not an occurs check, because F is a type function.
where
- headline_msg = misMatchOrCND ctxt item ty1 ty2
mismatch_msg = mkMismatchMsg item ty1 ty2
-- The following doesn't use the cterHasProblem mechanism because
@@ -2073,7 +2089,7 @@ eqInfoMsgs ty1 ty2
= Nothing
misMatchOrCND :: SolverReportErrCtxt -> ErrorItem
- -> TcType -> TcType -> MismatchMsg
+ -> TcType -> TcType -> TcM MismatchMsg
-- If oriented then ty1 is actual, ty2 is expected
misMatchOrCND ctxt item ty1 ty2
| insoluble_item -- See Note [Insoluble mis-match]
@@ -2082,10 +2098,10 @@ misMatchOrCND ctxt item ty1 ty2
|| null givens
= -- If the equality is unconditionally insoluble
-- or there is no context, don't report the context
- mkMismatchMsg item ty1 ty2
+ return $ mkMismatchMsg item ty1 ty2
| otherwise
- = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2)
+ = mkCouldNotDeduceErr givens (item :| []) (Just $ CND_ExpectedActual level ty1 ty2)
where
insoluble_item = case ei_m_reason item of
@@ -2275,9 +2291,8 @@ mkQCErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM
mkQCErr ctxt items
| item1 :| _ <- tryFilter (not . ei_suppress) items
-- Ignore multiple qc-errors on the same line
- = do { let msg = mkPlainMismatchMsg $
- CouldNotDeduce (getUserGivens ctxt) (item1 :| []) Nothing
- ; return $ important ctxt msg }
+ = do { couldNotDeduceErr <- mkCouldNotDeduceErr (getUserGivens ctxt) (item1 :| []) Nothing
+ ; return $ important ctxt $ mkPlainMismatchMsg couldNotDeduceErr }
mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport
@@ -2292,16 +2307,9 @@ mkDictErr ctxt orig_items
-- But we report only one of them (hence 'head') because they all
-- have the same source-location origin, to try avoid a cascade
-- of error from one location
- ; ( err, (imp_errs, hints) ) <-
- mk_dict_err ctxt (head (no_inst_items ++ overlap_items))
- ; return $
- SolverReport
- { sr_important_msg = SolverReportWithCtxt ctxt err
- , sr_supplementary = [ SupplementaryImportErrors imps
- | imps <- maybeToList (NE.nonEmpty imp_errs) ]
- , sr_hints = hints
- }
- }
+ ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items))
+ ; return $ important ctxt err
+ }
where
items = tryFilter (not . ei_suppress) orig_items
@@ -2335,28 +2343,29 @@ mkDictErr ctxt orig_items
-- matching and unifying instances, and say "The choice depends on the instantion of ...,
-- and the result of evaluating ...".
mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)
- -> TcM ( TcSolverReportMsg, ([ImportError], [GhcHint]) )
+ -> TcM TcSolverReportMsg
mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped))
= case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of
(Nothing, _) -> do -- No matches but perhaps several unifiers
{ (_, rel_binds, item) <- relevantBindings True ctxt item
; candidate_insts <- get_candidate_instances
- ; (imp_errs, field_suggestions) <- record_field_suggestions item
- ; return (CannotResolveInstance item unifiers candidate_insts rel_binds, (imp_errs, field_suggestions)) }
+ ; mb_noBuiltinInst_msg <- getNoBuiltinInstMsg item
+ ; return $
+ CannotResolveInstance item unifiers candidate_insts rel_binds mb_noBuiltinInst_msg
+ }
-- Some matches => overlap errors
(Just matchesNE, Nothing) -> return $
- ( OverlappingInstances item (NE.map fst matchesNE) unifiers, ([], []))
+ OverlappingInstances item (NE.map fst matchesNE) unifiers
(Just (match :| []), Just unsafe_overlappedNE) -> return $
- ( UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE), ([], []))
+ UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE)
(Just matches@(_ :| _), Just overlaps) ->
pprPanic "mk_dict_err: multiple matches with overlap" $
vcat [ text "matches:" <+> ppr matches
, text "overlaps:" <+> ppr overlaps
]
where
- orig = errorItemOrigin item
pred = errorItemPred item
(clas, tys) = getClassPredTys pred
unifiers = getCoherentUnifiers pot_unifiers
@@ -2381,43 +2390,6 @@ mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped))
in different_names && same_occ_names
| otherwise = False
- -- See Note [Out-of-scope fields with -XOverloadedRecordDot]
- record_field_suggestions :: ErrorItem -> TcM ([ImportError], [GhcHint])
- record_field_suggestions item = flip (maybe $ return ([], noHints)) record_field $ \name ->
- do { glb_env <- getGlobalRdrEnv
- ; lcl_env <- getLocalRdrEnv
- ; let field_name_hints = report_no_fieldnames item
- ; (errs, hints) <- if occ_name_in_scope glb_env lcl_env name
- then return ([], noHints)
- else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name)
- ; pure (errs, hints ++ field_name_hints)
- }
-
- -- get type names from instance
- -- resolve the type - if it's in scope is it a record?
- -- if it's a record, report an error - the record name + the field that could not be found
- report_no_fieldnames :: ErrorItem -> [GhcHint]
- report_no_fieldnames item
- | Just (EvVarDest evvar) <- ei_evdest item
- -- we can assume that here we have a `HasField @Symbol x r a` instance
- -- because of GetFieldOrigin in record_field
- , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar)
- , Just (r_tycon, _) <- tcSplitTyConApp_maybe r
- , Just x_name <- isStrLitTy x
- -- we check that this is a record type by checking whether it has any
- -- fields (in scope)
- , not . null $ tyConFieldLabels r_tycon
- = [RemindRecordMissingField x_name r a]
- | otherwise = []
-
- occ_name_in_scope glb_env lcl_env occ_name = not $
- null (lookupGRE glb_env (LookupOccName occ_name (RelevantGREsFOS WantNormal))) &&
- isNothing (lookupLocalRdrOcc lcl_env occ_name)
-
- record_field = case orig of
- GetFieldOrigin name -> Just (mkVarOccFS name)
- _ -> Nothing
-
{- Note [Report candidate instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have an unsolved (Num Int), where `Int` is not the Prelude Int,
@@ -2475,6 +2447,245 @@ results in
in the import of ‘Data.Monoid’
-}
+mkCouldNotDeduceErr
+ :: [UserGiven]
+ -> NonEmpty ErrorItem
+ -> Maybe CND_ExpectedActual
+ -> TcM MismatchMsg
+mkCouldNotDeduceErr user_givens items@(item :| _) mb_ea
+ = do { mb_noBuiltinInst_info <- getNoBuiltinInstMsg item
+ ; return $ CouldNotDeduce user_givens items mb_ea mb_noBuiltinInst_info }
+
+getNoBuiltinInstMsg :: ErrorItem -> TcM (Maybe NoBuiltinInstanceMsg)
+getNoBuiltinInstMsg item =
+ do { rdr_env <- getGlobalRdrEnv
+ ; fam_envs <- tcGetFamInstEnvs
+ ; mbNoHasFieldMsg <- hasFieldInfo_maybe rdr_env fam_envs item
+ ; return $ fmap NoBuiltinHasFieldMsg mbNoHasFieldMsg
+ }
+
+{- Note [Error messages for unsolved HasField constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The HasField type-class has special instance solving logic, implemented in
+'GHC.Tc.Instance.Class.{matchHasField,lookupHasFieldLabel}'. This logic is a
+bit complex, so it's useful to explain to the user why GHC might have failed to
+solve a 'HasField' constraint. GHC will emit the following error messages for
+an unsolved constraint of the form 'HasField fld_name rec_ty fld_ty'.
+These come in two flavours
+
+ HF1.
+ Actionable hints: suggest similarly named fields (in case of mis-spelling)
+ or provide import suggestions (e.g. out of scope field).
+ See 'GHC.Tc.Errors.Ppr.hasFieldMsgHints' which takes the returned
+ 'HasFieldMsg' and produces the hints we display to the user.
+
+ This depends on whether 'rec_ty' is a known fixed TyCon or not.
+
+ HF1a. If 'rec_ty' is a known record TyCon:
+ - If 'fld_name' is a record field of that TyCon, but it's not in scope,
+ then suggest importing it.
+ - Otherwise, we suggest similarly named fields, prioritising similar
+ name suggestions for record fields from that same TyCon.
+
+ HF1b. If 'rec_ty' is not a fixed TyCon (e.g. it's a metavariable):
+ - If 'fld_name' is an in-scope record field, don't suggest anything.
+ - Otherwise, suggest similar names.
+
+ HF2. Observations. GHC points out a fact to the user which might help them
+ understand the problem:
+
+ HF2a. 'fld_name' is not a string literal.
+ This is useful when the user has forgotten the quotes, e.g. they
+ have written 'getField @myFieldName' instead of 'getField @"myFieldName"'.
+
+ HF2b. 'rec_ty' is a TyCon without any fields, e.g. 'Int' or 'Bool'.
+
+ HF2c. The record field type 'fld_ty' contains existentials variables
+ or foralls. In the former case GHC doesn't generate a field selector
+ at all (it's a naughty record selector), while in the latter GHC
+ doesn't solve the constraint, because class instance arguments
+ can't contain foralls.
+
+ HF2d. The record field is a pattern synonym record field.
+ GHC does not generate 'HasField' instances for pattern synonym fields.
+
+ HF2e. The user is using -XRebindableSyntax, and this is not actually the
+ built-in HasField which GHC has special solving logic for.
+
+ This can happen rather easily, because the current usage of
+ -XOverloadedRecordUpdate requires enabling -XRebindableSyntax and
+ defining a custom 'setField' function.
+-}
+
+-- | Try to produce an explanatory message for why GHC was not able to use
+-- a built-in instance to solve a 'HasField' constraint.
+--
+-- See Note [Error messages for unsolved HasField constraints]
+hasFieldInfo_maybe :: GlobalRdrEnv -> FamInstEnvs -> ErrorItem -> TcM (Maybe HasFieldMsg)
+hasFieldInfo_maybe rdr_env fam_inst_envs item
+ | Just (x_ty, rec_ty, _wanted_field_ty) <- hasField_maybe (errorItemPred item)
+
+ -- This function largely replicates the logic
+ -- of 'GHC.Tc.Instance.Class.{matchHasField,lookupHasFieldLabel}'.
+ --
+ -- When that function fails to return a built-in HasField instance,
+ -- this function should generate an appropriate message which can be
+ -- displayed to the user as a hint.
+
+ = case isStrLitTy x_ty of
+ { Nothing ->
+ -- (HF2a) Field label is not a literal string.
+ return $ Just $ NotALiteralFieldName x_ty
+ ; Just x ->
+ do { dflags <- getDynFlags
+ ; let x_fl = FieldLabelString x
+ looking_for_field = LF WL_RecField WL_Global
+ fld_var_occ = mkVarOccFS x
+ lkup_fld_occ = LookupOccName fld_var_occ (RelevantGREsFOS WantField)
+ similar_names =
+ similarNameSuggestions looking_for_field
+ dflags rdr_env emptyLocalRdrEnv (mkRdrUnqual fld_var_occ)
+ ; (patsyns, suggs) <- partitionEithers <$> mapMaybeM with_parent similar_names
+ ; imp_suggs <- anyQualImportSuggestions looking_for_field lkup_fld_occ
+ ; case splitTyConApp_maybe rec_ty of
+ { Nothing -> do
+ -- (HF1b) Similar name and import suggestions with unknown TyCon.
+ --
+ -- Don't say 'rec is not a record type' if 'rec' is e.g. a type variable.
+ -- That's not really helpful, especially if 'rec' is a metavariable,
+ -- in which case this is most likely an ambiguity issue.
+ let gres = lookupGRE rdr_env lkup_fld_occ
+ case gres of
+ _:_ ->
+ -- If the name was in scope, don't give "similar name" suggestions.
+ return Nothing
+ [] -> do
+ return $ Just $
+ SuggestSimilarFields Nothing x_fl suggs patsyns imp_suggs
+ ; Just (rec_tc, rec_args)
+ | let rec_rep_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs rec_tc rec_args)
+ ->
+ if null $ tyConFieldLabels rec_rep_tc
+ then
+ -- (HF2b) Not a record TyCon
+ return $ Just $ NotARecordType rec_ty
+ else
+ case lookupTyConFieldLabel x_fl rec_rep_tc of
+ { Nothing -> do
+ -- (HF1a) Similar name and import suggestions with known TyCon.
+ return $ Just $
+ SuggestSimilarFields (Just (rec_tc, rec_rep_tc)) x_fl suggs patsyns imp_suggs
+ ; Just fl ->
+ -- The TyCon does have the field, so the issue might be that
+ -- it's not in scope or that the field is existential or higher-rank.
+ case lookupGRE_FieldLabel rdr_env fl of
+ { Nothing -> do
+ -- (HF1a) Not in scope. Try to suggest importing the field.
+ let lookup_gre =
+ LookupExactName
+ { lookupExactName = flSelector fl
+ , lookInAllNameSpaces = False }
+ imp_suggs <- anyQualImportSuggestions looking_for_field lookup_gre
+ return $ Just $ OutOfScopeField rec_tc fl imp_suggs
+ ; Just gre ->
+ let con1_nm =
+ case nonDetEltsUniqSet $ recFieldCons $ fieldGREInfo gre of
+ n : _ -> n
+ [] -> pprPanic "record field with no constructors" (ppr fl)
+ in case con1_nm of
+ { PatSynName {} ->
+ -- 'lookupTyConFieldLabel' always returns a DataCon field
+ pprPanic "hasFieldInfo_maybe: PatSyn" $
+ vcat [ text "tc:" <+> ppr rec_tc
+ , text "rep_tc:" <+> ppr rec_rep_tc
+ , text "con1_nm:" <+> ppr con1_nm
+ ]
+ ; DataConName dc1_nm -> do
+ dc1 <- tcLookupDataCon dc1_nm
+ let orig_field_ty = dataConFieldType dc1 (flLabel fl)
+ return $
+ -- (HF2c) Existential or higher-rank field.
+ -- See 'GHC.Tc.Instance.Class.matchHasField', which
+ -- has these same two conditions.
+ if | isExistentialRecordField orig_field_ty (RealDataCon dc1)
+ -- NB: use 'orig_field_ty' and not 'idType sel_id',
+ -- because the latter is 'unitTy' when there are existentials.
+ -> Just $ FieldTooFancy rec_tc x_fl FieldHasExistential
+ | not $ isTauTy orig_field_ty
+ -> Just $ FieldTooFancy rec_tc x_fl FieldHasForAlls
+ | otherwise
+ -> Nothing
+ -- Not sure what went wrong. Usually not a type error
+ -- in the field type, because the functional dependency
+ -- would cause a genuine equality error.
+ }}}}}}
+
+ -- (HF2e) It's a custom HasField constraint, not the one from GHC.Records.
+ | Just (tc, _) <- splitTyConApp_maybe (errorItemPred item)
+ , getOccString tc == "HasField"
+ , isHasFieldOrigin (errorItemOrigin item)
+ = return $ Just $ CustomHasField tc
+
+ | otherwise
+ = return Nothing
+
+ where
+
+ get_parent_nm :: Name -> TcM (Maybe (Either PatSyn TyCon))
+ get_parent_nm nm =
+ do { fld_id <- tcLookupId nm
+ ; return $
+ case idDetails fld_id of
+ RecSelId { sel_tycon = parent } ->
+ case parent of
+ RecSelData tc ->
+ Just $ Right tc
+ RecSelPatSyn ps ->
+ -- (HF2d) PatSyn record fields don't contribute 'HasField'
+ -- instances, so tell the user about that.
+ Just $ Left ps
+ _ -> Nothing
+ }
+
+ get_parent :: SimilarName -> TcM (Maybe (Either PatSyn TyCon))
+ get_parent (SimilarName nm) = get_parent_nm nm
+ get_parent (SimilarRdrName _ mb_gre _) =
+ case mb_gre of
+ Nothing -> return Nothing
+ Just gre -> get_parent_nm $ greName gre
+
+ with_parent :: SimilarName
+ -> TcM (Maybe (Either (PatSyn, SimilarName) (TyCon, SimilarName)))
+ with_parent n = fmap (bimap (,n) (,n)) <$> get_parent n
+
+-- | Is this constraint definitely 'HasField'?
+hasField_maybe :: PredType -> Maybe (Type, Type, Type)
+hasField_maybe pred =
+ case classifyPredType pred of
+ ClassPred cls tys
+ | className cls == hasFieldClassName
+ , [ _k, _rec_rep, _fld_rep, x_ty, rec_ty, fld_ty ] <- tys
+ -> Just (x_ty, rec_ty, fld_ty)
+ _ -> Nothing
+ -- NB: we deliberately don't handle rebound 'HasField' (with -XRebindableSyntax),
+ -- as GHC only has built-in instances for the built-in 'HasField' class.
+
+-- | Does this constraint arise from GHC internal mechanisms that desugar to
+-- usage of the 'HasField' typeclass (e.g. OverloadedRecordDot, etc)?
+--
+-- Just used heuristically to decide whether to print an informative message to
+-- the user (see (H2e) in Note [Error messages for unsolved HasField constraints]).
+isHasFieldOrigin :: CtOrigin -> Bool
+isHasFieldOrigin = \case
+ OccurrenceOf n ->
+ -- A heuristic...
+ getOccString n `elem` ["getField", "setField"]
+ OccurrenceOfRecSel {} -> True
+ RecordUpdOrigin {} -> True
+ RecordFieldProjectionOrigin {} -> True
+ GetFieldOrigin {} -> True
+ _ -> False
+
-----------------------
-- relevantBindings looks at the value environment and finds values whose
-- types mention any of the offending type variables. It has to be
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -63,7 +63,7 @@ import GHC.Core.InstEnv
import GHC.Core.TyCo.Rep (Type(..))
import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon,
pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll)
-import GHC.Core.PatSyn ( patSynName, pprPatSynType )
+import GHC.Core.PatSyn ( patSynName, pprPatSynType, PatSyn )
import GHC.Core.TyCo.Tidy
import GHC.Core.Predicate
import GHC.Core.Type
@@ -90,7 +90,7 @@ import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_provenanc
import GHC.Types.Error
import GHC.Types.Error.Codes
import GHC.Types.Hint
-import GHC.Types.Hint.Ppr ( pprSigLike ) -- & Outputable GhcHint
+import GHC.Types.Hint.Ppr ( pprSigLike )
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Id.Info ( RecSelParent(..) )
@@ -129,6 +129,9 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.BooleanFormula (pprBooleanFormulaNice)
+import Language.Haskell.Syntax.Basic (field_label, FieldLabelString (..))
+
+import Control.Monad (guard)
import qualified Data.Semigroup as S
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
@@ -4114,7 +4117,13 @@ pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) =
sep [ text "Unbound implicit parameter" <> plural preds
, nest 2 (pprParendTheta preds) ]
else
- let mismatch = CouldNotDeduce givens (item :| items) Nothing
+ let mismatch =
+ CouldNotDeduce
+ { cnd_user_givens = givens
+ , cnd_wanted = item :| items
+ , cnd_ea = Nothing
+ , cnd_noBuiltin_msg = Nothing
+ }
invis_bits = mismatchInvisibleBits mismatch
ppr_msg = pprMismatchMsg ctxt mismatch
in
@@ -4127,7 +4136,7 @@ pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) =
text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)
<+> text "from being solved."
pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
- (CannotResolveInstance item unifiers candidates rel_binds)
+ (CannotResolveInstance item unifiers candidates rel_binds mb_HasField_msg)
= pprWithInvisibleBits invis_bits $
vcat
[ no_inst_msg
@@ -4171,10 +4180,10 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
| lead_with_ambig
= (Set.empty, pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs))
| otherwise
- = let mismatch = CouldNotDeduce useful_givens (item :| []) Nothing
+ = let mismatch = CouldNotDeduce useful_givens (item :| []) Nothing mb_HasField_msg
in
( mismatchInvisibleBits mismatch
- , pprMismatchMsg ctxt $ CouldNotDeduce useful_givens (item :| []) Nothing
+ , pprMismatchMsg ctxt mismatch
)
-- Report "potential instances" only when the constraint arises
@@ -4202,6 +4211,9 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
| otherwise = Nothing
extra_note
+ | Just {} <- mb_HasField_msg
+ = empty
+
-- Flag up partially applied uses of (->)
| any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)
= text "(maybe you haven't applied a function to enough arguments?)"
@@ -4417,10 +4429,10 @@ mismatchInvisibleBits
, teq_mismatch_ty1 = ty1
, teq_mismatch_ty2 = ty2 })
= shouldPprWithInvisibleBits ty1 ty2 (errorItemOrigin item)
-mismatchInvisibleBits (CouldNotDeduce { cnd_extra = mb_extra })
- = case mb_extra of
+mismatchInvisibleBits (CouldNotDeduce { cnd_ea = mb_ea })
+ = case mb_ea of
Nothing -> Set.empty
- Just (CND_Extra _ ty1 ty2) ->
+ Just (CND_ExpectedActual _ ty1 ty2) ->
mayLookIdentical ty1 ty2
-- | Turn a 'MismatchMsg' into an 'SDoc'.
@@ -4612,9 +4624,14 @@ pprMismatchMsg ctxt
starts_with_vowel (c:_) = c `elem` ("AEIOU" :: String)
starts_with_vowel [] = False
-
-pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)
+pprMismatchMsg ctxt
+ (CouldNotDeduce { cnd_user_givens = useful_givens
+ , cnd_wanted = item :| others
+ , cnd_ea = mb_ea
+ , cnd_noBuiltin_msg = mb_NoBuiltin_msg
+ })
= vcat [ main_msg
+ , maybe empty pprNoBuiltinInstanceMsg mb_NoBuiltin_msg
, pprQCOriginExtra item
, ea_supplementary ]
where
@@ -4623,9 +4640,10 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)
| otherwise = vcat ( addArising ct_loc no_deduce_msg
: pp_from_givens useful_givens)
- ea_supplementary = case mb_extra of
- Nothing -> empty
- Just (CND_Extra level ty1 ty2) -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig
+ ea_supplementary = case mb_ea of
+ Nothing -> empty
+ Just (CND_ExpectedActual level ty1 ty2) ->
+ mk_supplementary_ea_msg ctxt level ty1 ty2 orig
ct_loc = errorItemCtLoc item
orig = ctLocOrigin ct_loc
@@ -5022,6 +5040,87 @@ pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) =
2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
, text "is not in scope" ])
+pprNoBuiltinInstanceMsg :: NoBuiltinInstanceMsg -> SDoc
+pprNoBuiltinInstanceMsg = \case
+ NoBuiltinHasFieldMsg msg -> pprHasFieldMsg msg
+
+pprHasFieldMsg :: HasFieldMsg -> SDoc
+pprHasFieldMsg = \case
+ NotALiteralFieldName ty ->
+ text "NB:" <+> quotes (ppr ty) <+> what
+ where
+ what
+ | Just {} <- getCastedTyVar_maybe ty
+ = text "is a type variable, not a string literal."
+ | otherwise
+ = text "is not a string literal."
+ NotARecordType ty ->
+ text "NB:" <+> quotes (ppr ty) <+> text "is not a record type."
+ OutOfScopeField tc fld _import_suggs ->
+ text "NB: the record field" <+> quotes (ppr fld) <+> text "of" <+> quotes (ppr tc) <+> text "is out of scope."
+ FieldTooFancy tc fld rea ->
+ case rea of
+ FieldHasExistential ->
+ text "NB: the record field" <+> quotes (ppr fld) <+> text "of" <+> quotes (ppr tc) <+> text "contains existential variables."
+ FieldHasForAlls ->
+ text "NB: the field type of the record field" <+> quotes (ppr fld) <+> text "of" <+> quotes (ppr tc) <+> text "is not a mono-type."
+ CustomHasField custom_hasField ->
+ text "NB:" <+> quotes (ppr custom_hasField) <+> text "is not the built-in"
+ <+> quotes (ppr hasFieldClassName) <+> text "class."
+ SuggestSimilarFields (Just (tc, rep_tc)) fld suggs pat_syns _imp_suggs ->
+ vcat
+ [ text "NB:" <+> quotes (ppr tc)
+ <+> text "does not have a record field named"
+ <+> quotes (ppr fld) <> dot
+ , pprHasFieldPatSynMsg fld pat_syns
+ , pprSameNameOtherTyCons (mapMaybe same_name_diff_tc suggs)
+ -- NB: The actual suggestions are dealt with by
+ -- GHC.Tc.Errors.hasFieldMsgHints. The logic here just covers
+ -- information for which there is no actionable hint.
+ ]
+ where
+ same_name_diff_tc (rep_tc', fld') = do
+ let occ = case fld' of
+ SimilarName n -> getOccFS n
+ SimilarRdrName n _ _ -> occNameFS $ rdrNameOcc n
+ guard $
+ rep_tc' /= rep_tc
+ &&
+ (fld == FieldLabelString occ)
+ return rep_tc'
+ SuggestSimilarFields Nothing fld _suggs pat_syns _imp_suggs ->
+ pprHasFieldPatSynMsg fld pat_syns
+ -- Most of the error message only makes sense when we know the TyCon.
+ -- In this "unknown TyCon" case, we only have:
+ -- - the "PatSyns don't give HasField instances" message
+ -- - the hints, which are handled separately (see 'hasFieldMsgHints').
+
+pprSameNameOtherTyCons :: [TyCon] -> SDoc
+pprSameNameOtherTyCons [] = empty
+pprSameNameOtherTyCons tcs =
+ other_types_have <+> text "a field of this name:"
+ <+> pprWithCommas (quotes . ppr) tcs <> dot
+ where
+ other_types_have :: SDoc
+ other_types_have = case tcs of
+ _:_:_ -> "Other types have"
+ _ -> "Another type has"
+
+pprHasFieldPatSynMsg :: FieldLabelString -> [(PatSyn, SimilarName)] -> SDoc
+pprHasFieldPatSynMsg fld pat_syns =
+ if any same_name pat_syns
+ then
+ text "Pattern synonym record fields do not contribute"
+ <+> quotes (ppr hasFieldClassName) <+> text "instances."
+ else empty
+ where
+ same_name (_,nm) =
+ let occ = case nm of
+ SimilarName n -> getOccFS n
+ SimilarRdrName n _ _ -> occNameFS $ rdrNameOcc n
+ in
+ occ == field_label fld
+
pprWhenMatching :: SolverReportErrCtxt -> WhenMatching -> SDoc
pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) =
sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->
@@ -5247,8 +5346,8 @@ tcSolverReportMsgHints ctxt = \case
-> noHints
AmbiguityPreventsSolvingCt {}
-> noHints
- CannotResolveInstance {}
- -> noHints
+ CannotResolveInstance { cannotResolve_noBuiltinMsg = mb_noBuiltin }
+ -> maybe noHints noBuiltinInstanceHints mb_noBuiltin
OverlappingInstances {}
-> noHints
UnsafeOverlap {}
@@ -5256,22 +5355,66 @@ tcSolverReportMsgHints ctxt = \case
MultiplicityCoercionsNotSupported {}
-> noHints
+noBuiltinInstanceHints :: NoBuiltinInstanceMsg -> [GhcHint]
+noBuiltinInstanceHints = \case
+ NoBuiltinHasFieldMsg noHasFieldMsg -> hasFieldMsgHints noHasFieldMsg
+
+hasFieldMsgHints :: HasFieldMsg -> [GhcHint]
+hasFieldMsgHints = \case
+ NotALiteralFieldName {} -> noHints
+ NotARecordType {} -> noHints
+ FieldTooFancy {} -> noHints
+ SuggestSimilarFields mb_orig_tc orig_fld suggs _patsyns imp_suggs ->
+ map (ImportSuggestion fld_occ) imp_suggs ++ similar_suggs
+ where
+ fld_occ = mkVarOccFS $ field_label orig_fld
+ similar_suggs =
+ case NE.nonEmpty $ filter different_name suggs of
+ Nothing -> noHints
+ Just neSuggs ->
+ case mb_orig_tc of
+ Just (orig_tc, orig_rep_tc) ->
+ -- We know the parent TyCon
+ [SuggestSimilarSelectors orig_tc orig_rep_tc orig_fld neSuggs]
+ Nothing ->
+ -- We don't know the parent TyCon
+ [ SuggestSimilarNames
+ (mkRdrUnqual fld_occ)
+ (fmap snd neSuggs)
+ ]
+ different_name ( _, nm ) =
+ let occ = case nm of
+ SimilarName n -> getOccFS n
+ SimilarRdrName n _ _ -> occNameFS $ rdrNameOcc n
+ in
+ orig_fld /= FieldLabelString occ
+ OutOfScopeField _tc fld import_suggs ->
+ map (ImportSuggestion (nameOccName $ flSelector fld)) import_suggs
+ CustomHasField {} -> noHints
+
mismatchMsgHints :: SolverReportErrCtxt -> MismatchMsg -> [GhcHint]
mismatchMsgHints ctxt msg =
+ mismatchMsgHasFieldHints msg ++
maybeToList [ hint | (exp,act) <- mismatchMsg_ExpectedActuals msg
, hint <- suggestAddSig ctxt exp act ]
+mismatchMsgHasFieldHints :: MismatchMsg -> [GhcHint]
+mismatchMsgHasFieldHints
+ (CouldNotDeduce { cnd_noBuiltin_msg = mb_noBuiltin }) =
+ maybe noHints noBuiltinInstanceHints mb_noBuiltin
+mismatchMsgHasFieldHints (BasicMismatch{}) = []
+mismatchMsgHasFieldHints (TypeEqMismatch{}) = []
+
mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type)
mismatchMsg_ExpectedActuals = \case
BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->
Just (exp, act)
TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->
Just (exp,act)
- CouldNotDeduce { cnd_extra = cnd_extra }
- | Just (CND_Extra _ exp act) <- cnd_extra
- -> Just (exp, act)
- | otherwise
- -> Nothing
+ CouldNotDeduce { cnd_ea = mb_ea } ->
+ case mb_ea of
+ Just (CND_ExpectedActual _ exp act) -> Just (exp, act)
+ Nothing -> Nothing
cannotUnifyVariableHints :: CannotUnifyVariableReason -> [GhcHint]
cannotUnifyVariableHints = \case
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -72,7 +72,7 @@ module GHC.Tc.Errors.Types (
, ExpectedActualInfo(..)
, TyVarInfo(..), SameOccInfo(..)
, AmbiguityInfo(..)
- , CND_Extra(..)
+ , CND_ExpectedActual(..)
, FitsMbSuppressed(..)
, ValidHoleFits(..), noValidHoleFits
, HoleFitDispConfig(..)
@@ -86,6 +86,9 @@ module GHC.Tc.Errors.Types (
, lookingForSubordinate
, HoleError(..)
, CoercibleMsg(..)
+ , NoBuiltinInstanceMsg(..)
+ , HasFieldMsg(..)
+ , TooFancyField(..)
, PotentialInstances(..)
, UnsupportedCallConvention(..)
, ExpectedBackends
@@ -200,7 +203,7 @@ import GHC.Tc.Utils.TcType (TcType, TcSigmaType, TcPredType,
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.Avail
-import GHC.Types.Hint (UntickedPromotedThing(..), AssumedDerivingStrategy(..), SigLike)
+import GHC.Types.Hint
import GHC.Types.ForeignCall (CLabelString)
import GHC.Types.Id.Info ( RecSelParent(..) )
import GHC.Types.Name (NamedThing(..), Name, OccName, getSrcLoc, getSrcSpan)
@@ -5615,6 +5618,7 @@ data TcSolverReportMsg
, cannotResolve_unifiers :: [ClsInst]
, cannotResolve_candidates :: [ClsInst]
, cannotResolve_relBinds :: RelevantBindings
+ , cannotResolve_noBuiltinMsg :: Maybe NoBuiltinInstanceMsg
}
-- | Could not solve a constraint using available instances
@@ -5675,15 +5679,20 @@ data MismatchMsg
-- Used for messages such as @"No instance for ..."@ and
-- @"Could not deduce ... from"@.
| CouldNotDeduce
- { cnd_user_givens :: [Implication]
+ { cnd_user_givens :: [Implication]
-- | The Wanted constraints we couldn't solve.
--
-- N.B.: the 'ErrorItem' at the head of the list has been tidied,
-- perhaps not the others.
- , cnd_wanted :: NE.NonEmpty ErrorItem
+ , cnd_wanted :: NE.NonEmpty ErrorItem
- -- | Some additional info consumed by 'mk_supplementary_ea_msg'.
- , cnd_extra :: Maybe CND_Extra
+ -- | Additional "expected/actual" information
+ -- consumed by 'mk_supplementary_ea_msg'.
+ , cnd_ea :: Maybe CND_ExpectedActual
+
+ -- | Additional message relating to unsolved constraints for
+ -- typeclasses which have built-in instances.
+ , cnd_noBuiltin_msg :: Maybe NoBuiltinInstanceMsg
}
deriving Generic
@@ -5753,7 +5762,7 @@ mkPlainMismatchMsg msg
-- | Additional information to be given in a 'CouldNotDeduce' message,
-- which is then passed on to 'mk_supplementary_ea_msg'.
-data CND_Extra = CND_Extra TypeOrKind Type Type
+data CND_ExpectedActual = CND_ExpectedActual TypeOrKind Type Type
-- | A cue to print out information about type variables,
-- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@.
@@ -5967,6 +5976,48 @@ data CoercibleMsg
-- Test cases: TcCoercibleFail.
| OutOfScopeNewtypeConstructor TyCon DataCon
+-- | Explains why GHC wasn't able to provide a built-in instance for
+-- a particular class.
+data NoBuiltinInstanceMsg
+ = NoBuiltinHasFieldMsg HasFieldMsg
+
+ -- Other useful constructors might be:
+ -- NoBuiltinTypeableMsg -- explains polykinded Typeable restrictions
+ -- NoBuiltinDataToTagMsg -- see conditions in Note [DataToTag overview]
+ -- NoBuiltinWithDictMsg -- see Note [withDict]
+
+-- | Explains why GHC wasn't able to provide a built-in 'HasField' instance
+-- for the given types.
+data HasFieldMsg
+ -- | The field is not a literal field name, e.g. @HasField x u v@ where @x@
+ -- is a type variable.
+ = NotALiteralFieldName Type
+ -- | The type we are selecting from is not a record type,
+ -- e.g. @HasField "fld" Int fld@.
+ | NotARecordType Type
+ -- | The field is out of scope.
+ | OutOfScopeField TyCon FieldLabel [ImportSuggestion]
+ -- | The field has a type which means that GHC cannot solve
+ -- a 'HasField' constraint for it.
+ | FieldTooFancy TyCon FieldLabelString TooFancyField
+ -- | No such field, but the field is perhaps mis-spelled;
+ -- here are some suggestions.
+ | SuggestSimilarFields
+ (Maybe (TyCon, TyCon)) -- ^ (optional) desired parent (tc and rep_tc)
+ FieldLabelString -- ^ field name
+ [(TyCon, SimilarName)] -- ^ suggestions (for this 'TyCon' or other 'TyCon's)
+ [(PatSyn, SimilarName)] -- ^ pattern synonyms with similarly named fields
+ [ImportSuggestion] -- ^ import suggestions
+
+ -- | Using -XRebindableSyntax and a different 'HasField'.
+ | CustomHasField TyCon -- ^ the custom HasField TyCon
+
+-- | Why is a record field "too fancy" for GHC to be able to properly
+-- solve a 'HasField' constraint?
+data TooFancyField
+ = FieldHasExistential
+ | FieldHasForAlls
+
-- | Explain a problem with an import.
data ImportError
-- | Couldn't find a module with the requested name.
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -1247,6 +1247,11 @@ matchHasField dflags short_cut clas tys mb_ct_loc
-- The selector must not be "naughty" (i.e. the field
-- cannot have an existentially quantified type),
-- and it must not be higher-rank.
+ --
+ -- See also 'GHC.Tc.Errors.hasFieldInfo_maybe', which is
+ -- responsible for the error messages in cases of unsolved
+ -- HasField constraints when the field type runs afoul
+ -- of these conditions.
; if (isNaughtyRecordSelector sel_id) || not (isTauTy sel_ty)
then try_user_instances
else
@@ -1306,6 +1311,11 @@ lookupHasFieldLabel
-- A complication is that `T` might be a data family, so we need to
-- look it up in the `fam_envs` to find its representation tycon.
lookupHasFieldLabel fam_inst_envs rdr_env arg_tys
+
+ -- NB: if you edit this function, you might also want to update
+ -- GHC.Tc.Errors.hasfieldInfo_maybe which is responsible for error messages
+ -- when GHC /does not/ solve a 'HasField' constraint.
+
| -- We are matching HasField {k} {r_rep} {a_rep} x r a...
(_k : _rec_rep : _fld_rep : x_ty : rec_ty : fld_ty : _) <- arg_tys
-- x should be a literal string
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -136,7 +136,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
; let (arg_names, is_infix) = collectPatSynArgInfo details
; (tclvl, wanted, ((lpat', args), pat_ty))
<- pushLevelAndCaptureConstraints $
- tcInferPat FRRPatSynArg PatSyn lpat $
+ tcInferPat FRRPatSynArg PatSynCtx lpat $
mapM tcLookupId arg_names
; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
@@ -421,7 +421,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
assertPpr (equalLength arg_names arg_tys) (ppr name $$ ppr arg_names $$ ppr arg_tys) $
pushLevelAndCaptureConstraints $
tcExtendNameTyVarEnv univ_tv_prs $
- tcCheckPat PatSyn lpat (unrestricted skol_pat_ty) $
+ tcCheckPat PatSynCtx lpat (unrestricted skol_pat_ty) $
do { let in_scope = mkInScopeSetList skol_univ_tvs
empty_subst = mkEmptySubst in_scope
; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs
@@ -843,7 +843,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
gen = Generated OtherExpansion SkipPmc
body = mkLHsWrap (mkWpLet req_ev_binds) $
L (getLoc lpat) $
- HsCase PatSyn (nlHsVar scrutinee) $
+ HsCase PatSynCtx (nlHsVar scrutinee) $
MG{ mg_alts = L (l2l $ getLoc lpat) cases
, mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty gen
}
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Tc.TyCl.Utils(
addTyConsToGblEnv, mkDefaultMethodType,
-- * Record selectors
- tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
+ tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector,
) where
import GHC.Prelude
@@ -899,7 +899,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- Selector type; Note [Polymorphic selectors]
- (univ_tvs, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
+ (_, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
field_ty = conLikeFieldType con1 lbl
field_ty_tvs = tyCoVarsOfType field_ty
@@ -909,17 +909,13 @@ mkOneRecordSelector all_cons idDetails fl has_sel
conLikeUserTyVarBinders con1
-- is_naughty: see Note [Naughty record selectors]
- is_naughty = not ok_scoping || no_selectors
- ok_scoping = case con1 of
- RealDataCon {} -> field_ty_tvs `subVarSet` data_ty_tvs
- PatSynCon {} -> field_ty_tvs `subVarSet` mkVarSet univ_tvs
- -- In the PatSynCon case, the selector type is (data_ty -> field_ty), but
- -- fvs(data_ty) are all universals (see Note [Pattern synonym result type] in
- -- GHC.Core.PatSyn, so no need to check them.
-
- no_selectors = has_sel == NoFieldSelectors -- No field selectors => all are naughty
- -- thus suppressing making a binding
- -- A slight hack!
+ is_naughty = isExistentialRecordField field_ty con1 || no_selectors
+
+ no_selectors = has_sel == NoFieldSelectors
+ -- For PatternSynonyms with -XNoFieldSelectors, pretend the fields
+ -- are naughty record selectors to suppress making a binding.
+ --
+ -- See Note [NoFieldSelectors and naughty record selectors]
sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
| otherwise = mkForAllTys sel_tvbs $
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -524,7 +524,7 @@ data CtOrigin
----------- Below here, all are Origins for Wanted constraints ------------
| OccurrenceOf Name -- ^ Occurrence of an overloaded identifier
- | OccurrenceOfRecSel RdrName -- ^ Occurrence of a record selector
+ | OccurrenceOfRecSel (LocatedN RdrName) -- ^ Occurrence of a record selector
| AppOrigin -- ^ An application of some kind
| SpecPragOrigin UserTypeCtxt -- ^ Specialisation pragma for
@@ -558,7 +558,10 @@ data CtOrigin
-- IMPORTANT: These constraints will never cause errors;
-- See Note [Constraints to ignore] in GHC.Tc.Errors
| SectionOrigin
- | GetFieldOrigin FastString
+ | GetFieldOrigin (LocatedN FastString)
+
+ -- | A overloaded record field projection like @.fld@ or @.fld1.fld2.fld@.
+ | RecordFieldProjectionOrigin (FieldLabelStrings GhcRn)
| TupleOrigin -- (..,..)
| ExprSigOrigin -- e :: ty
| PatSigOrigin -- p :: ty
@@ -566,7 +569,7 @@ data CtOrigin
| ProvCtxtOrigin -- The "provided" context of a pattern synonym signature
(PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in
-- particular the name and the right-hand side
- | RecordUpdOrigin
+ | RecordUpdOrigin (LHsRecUpdFields GhcRn)
| ViewPatOrigin
-- | 'ScOrigin' is used only for the Wanted constraints for the
@@ -737,7 +740,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e
exprCtOrigin :: HsExpr GhcRn -> CtOrigin
exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name
-exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (field_label $ unLoc $ dfoLabel f)
+exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (fmap field_label $ dfoLabel f)
exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l
exprCtOrigin (ExplicitList {}) = ListOrigin
exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip
@@ -749,9 +752,9 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1
exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op
exprCtOrigin (NegApp _ e _) = lexprCtOrigin e
exprCtOrigin (HsPar _ e) = lexprCtOrigin e
-exprCtOrigin (HsProjection _ _) = SectionOrigin
-exprCtOrigin (SectionL _ _ _) = SectionOrigin
-exprCtOrigin (SectionR _ _ _) = SectionOrigin
+exprCtOrigin (HsProjection _ p) = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p)
+exprCtOrigin (SectionL {}) = SectionOrigin
+exprCtOrigin (SectionR {}) = SectionOrigin
exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum"
exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
@@ -760,7 +763,7 @@ exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e
exprCtOrigin (HsDo {}) = DoOrigin
exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction"
-exprCtOrigin (RecordUpd {}) = RecordUpdOrigin
+exprCtOrigin (RecordUpd _ _ flds)= RecordUpdOrigin flds
exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence"
exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e
@@ -779,7 +782,7 @@ exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOri
| OrigStmt _ <- thing = DoOrigin
| OrigPat p <- thing = DoPatOrigin p
exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
-exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f)
+exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f)
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
@@ -937,7 +940,7 @@ ppr_br AppOrigin = text "an application"
ppr_br (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)]
ppr_br (OverLabelOrigin l) = hsep [text "the overloaded label"
,quotes (char '#' <> ppr l)]
-ppr_br RecordUpdOrigin = text "a record update"
+ppr_br (RecordUpdOrigin {}) = text "a record update"
ppr_br ExprSigOrigin = text "an expression type signature"
ppr_br PatSigOrigin = text "a pattern type signature"
ppr_br PatOrigin = text "a pattern"
@@ -945,6 +948,7 @@ ppr_br ViewPatOrigin = text "a view pattern"
ppr_br (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)]
ppr_br (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)]
ppr_br SectionOrigin = text "an operator section"
+ppr_br (RecordFieldProjectionOrigin p) = text "the record selector" <+> quotes (ppr p)
ppr_br (GetFieldOrigin f) = hsep [text "selecting the field", quotes (ppr f)]
ppr_br AssocFamPatOrigin = text "the LHS of a family instance"
ppr_br TupleOrigin = text "a tuple"
=====================================
compiler/GHC/Types/Hint.hs
=====================================
@@ -42,12 +42,14 @@ import GHC.Core.TyCon (TyCon)
import GHC.Core.Type (Type)
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName)
-import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec)
+import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec, GlobalRdrElt)
import GHC.Types.SrcLoc (SrcSpan)
import GHC.Types.Basic (Activation, RuleName)
import GHC.Parser.Errors.Basic
import GHC.Utils.Outputable
-import GHC.Data.FastString (fsLit, FastString)
+import GHC.Data.FastString (fsLit)
+
+import Language.Haskell.Syntax.Basic (FieldLabelString)
import Data.Typeable ( Typeable )
import Data.Map.Strict (Map)
@@ -394,6 +396,12 @@ data GhcHint
-}
| SuggestSimilarNames RdrName (NE.NonEmpty SimilarName)
+ {-| Suggest a similar record selector that the user might have meant.
+
+ Test case: T26480b.
+ -}
+ | SuggestSimilarSelectors TyCon TyCon FieldLabelString (NE.NonEmpty (TyCon, SimilarName))
+
{-| Remind the user that the field selector has been suppressed
because of -XNoFieldSelectors.
@@ -464,9 +472,6 @@ data GhcHint
{-| Suggest eta-reducing a type synonym used in the implementation
of abstract data. -}
| SuggestEtaReduceAbsDataTySyn TyCon
- {-| Remind the user that there is no field of a type and name in the record,
- constructors are in the usual order $x$, $r$, $a$ -}
- | RemindRecordMissingField FastString Type Type
{-| Suggest binding the type variable on the LHS of the type declaration
-}
| SuggestBindTyVarOnLhs RdrName
@@ -579,7 +584,7 @@ data HowInScope
data SimilarName
= SimilarName Name
- | SimilarRdrName RdrName (Maybe HowInScope)
+ | SimilarRdrName RdrName (Maybe GlobalRdrElt) (Maybe HowInScope)
-- | Some kind of signature, such as a fixity signature, standalone
-- kind signature, COMPLETE pragma, role annotation, etc.
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -15,7 +15,7 @@ import GHC.Types.Hint
import GHC.Core.FamInstEnv (FamFlavor(..))
import GHC.Core.TyCon
-import GHC.Core.TyCo.Rep ( mkVisFunTyMany )
+import GHC.Hs.Binds (hsSigDoc)
import GHC.Hs.Expr () -- instance Outputable
import GHC.Types.Id
import GHC.Types.Name
@@ -25,14 +25,16 @@ import GHC.Unit.Module.Imported (ImportedModsVal(..))
import GHC.Unit.Types
import GHC.Utils.Outputable
+import qualified GHC.LanguageExtensions as LangExt
+
import GHC.Driver.Flags
+import Language.Haskell.Syntax.Basic (FieldLabelString)
+
+import Data.List (partition)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Hs.Binds (hsSigDoc)
-
instance Outputable GhcHint where
ppr = \case
UnknownHint m
@@ -198,7 +200,9 @@ instance Outputable GhcHint where
, nest 2 (pprWithCommas pp_item $ NE.toList similar_names) ]
where
tried_ns = occNameSpace $ rdrNameOcc tried_rdr_name
- pp_item = pprSimilarName tried_ns
+ pp_item = pprSimilarName (Just tried_ns)
+ SuggestSimilarSelectors tc rep_tc fld suggs ->
+ pprSimilarFields tc rep_tc fld (NE.toList suggs)
RemindFieldSelectorSuppressed rdr_name parents
-> text "Notice that" <+> quotes (ppr rdr_name)
<+> text "is a field selector" <+> whose
@@ -255,12 +259,6 @@ instance Outputable GhcHint where
SuggestEtaReduceAbsDataTySyn tc
-> text "If possible, eta-reduce the type synonym" <+> ppr_tc <+> text "so that it is nullary."
where ppr_tc = quotes (ppr $ tyConName tc)
- RemindRecordMissingField x r a ->
- text "NB: There is no field selector" <+> ppr_sel
- <+> text "in scope for record type" <+> ppr_r
- where ppr_sel = quotes (ftext x <+> dcolon <+> ppr_arr_r_a)
- ppr_arr_r_a = ppr $ mkVisFunTyMany r a
- ppr_r = quotes $ ppr r
SuggestBindTyVarOnLhs tv
-> text "Bind" <+> quotes (ppr tv) <+> text "on the LHS of the type declaration"
SuggestAnonymousWildcard
@@ -405,10 +403,10 @@ pprImportSuggestion dc_occ (ImportDataCon { ies_suggest_import_from = Just mod
parens_sp d = parens (space <> d <> space)
-- | Pretty-print a 'SimilarName'.
-pprSimilarName :: NameSpace -> SimilarName -> SDoc
+pprSimilarName :: Maybe NameSpace -> SimilarName -> SDoc
pprSimilarName _ (SimilarName name)
= quotes (ppr name) <+> parens (pprDefinedAt name)
-pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)
+pprSimilarName mb_tried_ns (SimilarRdrName rdr_name _gre_info how_in_scope)
= pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc
where
loc = case how_in_scope of
@@ -421,8 +419,12 @@ pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)
ImportedBy is ->
parens (text "imported from" <+> ppr (moduleName $ is_mod is))
pp_ns :: RdrName -> SDoc
- pp_ns rdr | ns /= tried_ns = pprNameSpace ns
- | otherwise = empty
+ pp_ns rdr
+ | Just tried_ns <- mb_tried_ns
+ , ns /= tried_ns
+ = pprNameSpace ns
+ | otherwise
+ = empty
where ns = rdrNameSpace rdr
pprImpliedExtensions :: LangExt.Extension -> SDoc
@@ -437,6 +439,34 @@ pprPrefixUnqual :: Name -> SDoc
pprPrefixUnqual name =
pprPrefixOcc (getOccName name)
+pprSimilarFields :: TyCon -> TyCon -> FieldLabelString -> [(TyCon, SimilarName)] -> SDoc
+pprSimilarFields _tc rep_tc _fld suggs
+ | null suggs
+ = empty
+ -- There are similarly named fields for the right TyCon: report those first.
+ | same_tc_sugg1 : same_tc_rest <- same_tc
+ = case same_tc_rest of
+ [] ->
+ text "Perhaps use" <+> ppr_same_tc same_tc_sugg1 <> dot
+ _ ->
+ vcat [ text "Perhaps use one of"
+ , nest 2 $ pprWithCommas ppr_same_tc same_tc
+ ]
+ -- Otherwise, report the similarly named fields for other TyCons.
+ | otherwise
+ = vcat [ text "Perhaps use" <+> similar_field <+> text "of another type" <> colon
+ , nest 2 $ pprWithCommas ppr_other_tc others
+ ]
+ where
+ (same_tc, others) = partition ((== rep_tc) . fst) suggs
+ similar_field =
+ case others of
+ _:_:_ -> "one of the similarly named fields"
+ _ -> "the similarly named field"
+ ppr_same_tc (_, nm) = pprSimilarName Nothing nm
+ ppr_other_tc (other_tc, nm) =
+ quotes (ppr other_tc) <> colon <+> pprSimilarName Nothing nm
+
pprSigLike :: SigLike -> SDoc
pprSigLike = \case
SigLikeSig sig ->
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -1403,7 +1403,7 @@ data HsMatchContext fn
| ThPatSplice -- ^A Template Haskell pattern splice
| ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |]
- | PatSyn -- ^A pattern synonym declaration
+ | PatSynCtx -- ^A pattern synonym declaration
| LazyPatCtx -- ^An irrefutable pattern
{- Note [mc_fun field of FunRhs]
@@ -1467,8 +1467,8 @@ qualifiedDoModuleName_maybe ctxt = case ctxt of
isPatSynCtxt :: HsMatchContext fn -> Bool
isPatSynCtxt ctxt =
case ctxt of
- PatSyn -> True
- _ -> False
+ PatSynCtx -> True
+ _ -> False
isComprehensionContext :: HsStmtContext fn -> Bool
-- Uses comprehension syntax [ e | quals ]
=====================================
testsuite/tests/overloadedrecflds/should_fail/T26480.hs
=====================================
@@ -0,0 +1,65 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module T26480 where
+
+import Data.Proxy
+import GHC.TypeLits
+import GHC.Records
+
+import T26480_aux1 (R1)
+import qualified T26480_aux2 as XXX (R2)
+
+data S = MkS { fld_s :: Int }
+
+data E where
+ MkE :: { fld_e :: e } -> E
+
+data Q = MkQ { fld_q :: forall a. a -> a }
+
+data T = MkT { specificFieldName :: Int }
+
+data G = MkG { xyzzywyzzydyzzy :: Int }
+
+pattern P :: Int -> S
+pattern P { patSynField } = MkS patSynField
+
+-- Not a literal string
+test1 :: forall (fld_s :: Symbol). Proxy fld_s -> S -> Int
+test1 _ = getField @fld_s
+
+-- Not a record type
+test2 :: Int -> Int
+test2 = getField @"int_fld"
+
+-- Field out of scope: unqualified import
+test3a :: R1 -> Int
+test3a = getField @"f1"
+
+-- Field out of scope: qualified import
+test3b :: XXX.R2 -> Int
+test3b = getField @"f2"
+
+-- Existential record field
+test4 :: E -> Int
+test4 = getField @"fld_e"
+
+-- Record field contains forall
+test5 :: Q -> Bool -> Bool
+test5 = getField @"fld_q"
+
+-- Record field is misspelled
+test6 :: T -> Int
+test6 = getField @"specificFieldTame"
+
+-- Record field is for a different type
+test7 :: T -> Int
+test7 = getField @"xyzzywyzzydyzzy"
+
+-- Record field is misspelled and is for a different type
+test8 :: T -> Int
+test8 = getField @"xyzzywyzzyzyzzy"
+
+-- Pattern synonym field
+test9 :: S -> Int
+test9 = getField @"patSynField"
=====================================
testsuite/tests/overloadedrecflds/should_fail/T26480.stderr
=====================================
@@ -0,0 +1,82 @@
+T26480.hs:29:11: error: [GHC-39999]
+ • No instance for ‘HasField fld_s S Int’
+ arising from a use of ‘getField’
+ NB: ‘fld_s’ is a type variable, not a string literal.
+ • In the expression: getField @fld_s
+ In an equation for ‘test1’: test1 _ = getField @fld_s
+
+T26480.hs:33:9: error: [GHC-39999]
+ • No instance for ‘HasField "int_fld" Int Int’
+ arising from a use of ‘getField’
+ NB: ‘Int’ is not a record type.
+ • In the expression: getField @"int_fld"
+ In an equation for ‘test2’: test2 = getField @"int_fld"
+
+T26480.hs:37:10: error: [GHC-39999]
+ • No instance for ‘HasField "f1" R1 Int’
+ arising from a use of ‘getField’
+ NB: the record field ‘f1’ of ‘R1’ is out of scope.
+ • In the expression: getField @"f1"
+ In an equation for ‘test3a’: test3a = getField @"f1"
+ Suggested fix:
+ Add ‘f1’ to the import list in the import of ‘T26480_aux1’
+ (at T26480.hs:10:1-23).
+
+T26480.hs:41:10: error: [GHC-39999]
+ • No instance for ‘HasField "f2" XXX.R2 Int’
+ arising from a use of ‘getField’
+ NB: the record field ‘f2’ of ‘XXX.R2’ is out of scope.
+ • In the expression: getField @"f2"
+ In an equation for ‘test3b’: test3b = getField @"f2"
+ Suggested fix:
+ Add ‘f2’ to the import list in the import of ‘T26480_aux2’
+ (at T26480.hs:11:1-40).
+
+T26480.hs:45:9: error: [GHC-39999]
+ • No instance for ‘HasField "fld_e" E Int’
+ arising from a use of ‘getField’
+ NB: the record field ‘fld_e’ of ‘E’ contains existential variables.
+ • In the expression: getField @"fld_e"
+ In an equation for ‘test4’: test4 = getField @"fld_e"
+
+T26480.hs:49:9: error: [GHC-39999]
+ • No instance for ‘HasField "fld_q" Q (Bool -> Bool)’
+ arising from a use of ‘getField’
+ NB: the field type of the record field ‘fld_q’ of ‘Q’ is not a mono-type.
+ • In the expression: getField @"fld_q"
+ In an equation for ‘test5’: test5 = getField @"fld_q"
+
+T26480.hs:53:9: error: [GHC-39999]
+ • No instance for ‘HasField "specificFieldTame" T Int’
+ arising from a use of ‘getField’
+ NB: ‘T’ does not have a record field named ‘specificFieldTame’.
+ • In the expression: getField @"specificFieldTame"
+ In an equation for ‘test6’: test6 = getField @"specificFieldTame"
+ Suggested fix: Perhaps use ‘specificFieldName’ (line 20).
+
+T26480.hs:57:9: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzydyzzy" T Int’
+ arising from a use of ‘getField’
+ NB: ‘T’ does not have a record field named ‘xyzzywyzzydyzzy’.
+ Another type has a field of this name: ‘G’.
+ • In the expression: getField @"xyzzywyzzydyzzy"
+ In an equation for ‘test7’: test7 = getField @"xyzzywyzzydyzzy"
+
+T26480.hs:61:9: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzyzyzzy" T Int’
+ arising from a use of ‘getField’
+ NB: ‘T’ does not have a record field named ‘xyzzywyzzyzyzzy’.
+ • In the expression: getField @"xyzzywyzzyzyzzy"
+ In an equation for ‘test8’: test8 = getField @"xyzzywyzzyzyzzy"
+ Suggested fix:
+ Perhaps use the similarly named field of another type:
+ ‘G’: ‘xyzzywyzzydyzzy’ (line 22)
+
+T26480.hs:65:9: error: [GHC-39999]
+ • No instance for ‘HasField "patSynField" S Int’
+ arising from a use of ‘getField’
+ NB: ‘S’ does not have a record field named ‘patSynField’.
+ Pattern synonym record fields do not contribute ‘HasField’ instances.
+ • In the expression: getField @"patSynField"
+ In an equation for ‘test9’: test9 = getField @"patSynField"
+
=====================================
testsuite/tests/overloadedrecflds/should_fail/T26480_aux1.hs
=====================================
@@ -0,0 +1,4 @@
+module T26480_aux1 where
+
+data R1 = MkR1 { f1 :: Int }
+data R2 = MkR2 { f2 :: Int }
=====================================
testsuite/tests/overloadedrecflds/should_fail/T26480_aux2.hs
=====================================
@@ -0,0 +1,3 @@
+module T26480_aux2 where
+
+data R2 = MkR2 { f2 :: Int }
=====================================
testsuite/tests/overloadedrecflds/should_fail/T26480b.hs
=====================================
@@ -0,0 +1,57 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedRecordUpdate #-}
+
+module T26480b where
+
+import Prelude
+import Data.Proxy
+import GHC.TypeLits
+import GHC.Records
+
+
+setField
+ :: forall (fld :: Symbol) rec ty
+ . HasField fld rec ty => ty -> rec -> rec
+setField _ r = r
+
+data N = N { no :: H }
+
+data D = MkD{ field1 :: G }
+
+data G = MkG { xyzzywyzzydyzzy :: H }
+
+data H = MkH { field2 :: Int }
+
+-- Direct usage of 'getField'
+test1 :: G -> H
+test1 = getField @"xyzzywyzzydyzza"
+
+test1' :: N -> H
+test1' = getField @"xyzzywyzzydyzzy"
+
+test1'' :: N -> H
+test1'' = getField @"ayzzywyzzydyzzy"
+
+-- Record dot, applied
+test2a :: G -> H
+test2a g = g.xyzzywyzzydyzzb
+
+test2b :: D -> H
+test2b g = g.field1.xyzzywyzzydyzzc
+
+-- Record dot, bare selector
+test3a :: G -> H
+test3a = (.xyzzywyzzydyzzd)
+
+test3b :: D ->H
+test3b = (.field1.xyzzywyzzydyzze)
+
+-- Overloaded record update
+test4a :: G -> G
+test4a d = d { xyzzywyzzydyzzf = MkG ( MkH 3 ) }
+
+test4b :: D -> D
+test4b d = d { field1.xyzzywyzzydyzzg = MkH 3 }
=====================================
testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr
=====================================
@@ -0,0 +1,74 @@
+T26480b.hs:30:9: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzydyzza" G H’
+ arising from a use of ‘getField’
+ NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzza’.
+ • In the expression: getField @"xyzzywyzzydyzza"
+ In an equation for ‘test1’: test1 = getField @"xyzzywyzzydyzza"
+ Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
+
+T26480b.hs:33:10: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzydyzzy" N H’
+ arising from a use of ‘getField’
+ NB: ‘N’ does not have a record field named ‘xyzzywyzzydyzzy’.
+ Another type has a field of this name: ‘G’.
+ • In the expression: getField @"xyzzywyzzydyzzy"
+ In an equation for ‘test1'’: test1' = getField @"xyzzywyzzydyzzy"
+
+T26480b.hs:36:11: error: [GHC-39999]
+ • No instance for ‘HasField "ayzzywyzzydyzzy" N H’
+ arising from a use of ‘getField’
+ NB: ‘N’ does not have a record field named ‘ayzzywyzzydyzzy’.
+ • In the expression: getField @"ayzzywyzzydyzzy"
+ In an equation for ‘test1''’: test1'' = getField @"ayzzywyzzydyzzy"
+ Suggested fix:
+ Perhaps use the similarly named field of another type:
+ ‘G’: ‘xyzzywyzzydyzzy’ (line 24)
+
+T26480b.hs:40:12: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzydyzzb" G H’
+ arising from selecting the field ‘xyzzywyzzydyzzb’
+ NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzb’.
+ • In the expression: g.xyzzywyzzydyzzb
+ In an equation for ‘test2a’: test2a g = g.xyzzywyzzydyzzb
+ Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
+
+T26480b.hs:43:12: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzydyzzc" G H’
+ arising from selecting the field ‘xyzzywyzzydyzzc’
+ NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzc’.
+ • In the expression: g.field1.xyzzywyzzydyzzc
+ In an equation for ‘test2b’: test2b g = g.field1.xyzzywyzzydyzzc
+ Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
+
+T26480b.hs:47:10: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzydyzzd" G H’
+ arising from the record selector ‘xyzzywyzzydyzzd’
+ NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzd’.
+ • In the expression: (.xyzzywyzzydyzzd)
+ In an equation for ‘test3a’: test3a = (.xyzzywyzzydyzzd)
+ Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
+
+T26480b.hs:50:10: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzydyzze" G H’
+ NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzze’.
+ • In the expression: (.field1.xyzzywyzzydyzze)
+ In an equation for ‘test3b’: test3b = (.field1.xyzzywyzzydyzze)
+ Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
+
+T26480b.hs:54:12: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzydyzzf" G G’
+ arising from a record update
+ NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzf’.
+ • In the expression: d {xyzzywyzzydyzzf = MkG (MkH 3)}
+ In an equation for ‘test4a’:
+ test4a d = d {xyzzywyzzydyzzf = MkG (MkH 3)}
+ Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
+
+T26480b.hs:57:12: error: [GHC-39999]
+ • No instance for ‘HasField "xyzzywyzzydyzzg" G H’
+ NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzg’.
+ • In the expression: d {field1.xyzzywyzzydyzzg = MkH 3}
+ In an equation for ‘test4b’:
+ test4b d = d {field1.xyzzywyzzydyzzg = MkH 3}
+ Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
+
=====================================
testsuite/tests/overloadedrecflds/should_fail/all.T
=====================================
@@ -33,6 +33,8 @@ test('hasfieldfail03', normal, compile_fail, [''])
test('hasfieldfail04', normal, compile_fail, [''])
test('T14953', [extra_files(['T14953_A.hs', 'T14953_B.hs'])],
multimod_compile_fail, ['T14953', ''])
+test('T26480', extra_files(['T26480_aux1.hs', 'T26480_aux2.hs']), multimod_compile_fail, ['T26480', '-v0'])
+test('T26480b', normal, compile_fail, [''])
test('DuplicateExports', normal, compile_fail, [''])
test('T17420', [extra_files(['T17420A.hs'])], multimod_compile_fail,
['T17420', ''])
=====================================
testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr
=====================================
@@ -1,11 +1,15 @@
[1 of 3] Compiling HasFieldFail01_A ( HasFieldFail01_A.hs, HasFieldFail01_A.o )
[2 of 3] Compiling Main ( hasfieldfail01.hs, hasfieldfail01.o )
-
hasfieldfail01.hs:9:15: error: [GHC-39999]
• No instance for ‘HasField "foo" T Int’
arising from a use of ‘getField’
+ NB: the record field ‘foo’ of ‘T’ is out of scope.
• In the first argument of ‘print’, namely
‘(getField @"foo" (MkT 42) :: Int)’
In the expression: print (getField @"foo" (MkT 42) :: Int)
In an equation for ‘main’:
main = print (getField @"foo" (MkT 42) :: Int)
+ Suggested fix:
+ Add ‘foo’ to the import list in the import of ‘HasFieldFail01_A’
+ (at hasfieldfail01.hs:3:1-32).
+
=====================================
testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr
=====================================
@@ -1,12 +1,14 @@
-
hasfieldfail02.hs:11:5: error: [GHC-39999]
• No instance for ‘HasField "foo" T a1’
arising from a use of ‘getField’
+ NB: the field type of the record field ‘foo’ of ‘T’ is not a mono-type.
• In the expression: getField @"foo" (MkT id)
In an equation for ‘x’: x = getField @"foo" (MkT id)
hasfieldfail02.hs:17:5: error: [GHC-39999]
• No instance for ‘HasField "bar" U a0’
arising from a use of ‘getField’
+ NB: the record field ‘bar’ of ‘U’ contains existential variables.
• In the expression: getField @"bar" (MkU True)
In an equation for ‘y’: y = getField @"bar" (MkU True)
+
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
=====================================
@@ -16,6 +16,7 @@ RecordDotSyntaxFail11.hs:8:3: error: [GHC-39999]
RecordDotSyntaxFail11.hs:8:11: error: [GHC-39999]
• No instance for ‘GHC.Internal.Records.HasField "baz" Int a0’
+ NB: ‘Int’ is not a record type.
• In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’
In a stmt of a 'do' block: print $ (.foo.bar.baz) a
In the expression:
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs
=====================================
@@ -28,10 +28,26 @@ data Baz = Baz { baz :: Quux } deriving (Show, Eq)
instance HasField "baz" Baz Quux where
hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r)
--- 'Quux' has a 'quux' field of type 'Int'
-data Quux = Quux { quux :: Int } deriving (Show, Eq)
+-- 'Quux' has 'quux' fields of type 'Wob'
+data Quux = Quux { quux1, quux2, quux3 :: Wob } deriving (Show, Eq)
-- Forget to write this type's 'HasField' instance
+-- 'Wob' has a field of type 'Bool'
+data Wob = Wob { wob :: Bool } deriving (Show, Eq)
+instance HasField "wob" Wob Bool where
+ hasField r = (\x -> case r of Wob { .. } -> Wob { wob = x, .. }, wob r)
+
+myQuux :: Quux
+myQuux = Quux w w w
+ where w = Wob { wob = True }
+
main = do
- let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
- print $ a.foo.bar.baz.quux
+ let
+ a = Foo { foo = Bar{ bar = Baz { baz = myQuux } } }
+ print @Quux $ a.foo.bar.baz.quux1
+
+ let b = myQuux
+ print @Quux $ b.quux2
+
+ let c = Foo { foo = Bar{ bar = Baz { baz = myQuux } } }
+ print @Bool $ a.foo.bar.baz.quux3.wob
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
=====================================
@@ -1,28 +1,36 @@
-RecordDotSyntaxFail8.hs:37:3: error: [GHC-39999]
- • Ambiguous type variable ‘a0’ arising from a use of ‘print’
- prevents the constraint ‘(Show a0)’ from being solved.
- Probable fix: use a type annotation to specify what ‘a0’ should be.
- Potentially matching instances:
- instance Show Ordering -- Defined in ‘GHC.Internal.Show’
- instance Show Bar -- Defined at RecordDotSyntaxFail8.hs:22:41
- ...plus 29 others
- ...plus 13 instances involving out-of-scope types
- (use -fprint-potential-instances to see them all)
- • In the first argument of ‘($)’, namely ‘print’
- In a stmt of a 'do' block: print $ ....baz.quux
+RecordDotSyntaxFail8.hs:47:17: error: [GHC-39999]
+ • No instance for ‘HasField "quux1" Quux Quux’
+ arising from selecting the field ‘quux1’
+ NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class.
+ • In the second argument of ‘($)’, namely ‘....bar.baz.quux1’
+ In a stmt of a 'do' block: print @Quux $ ....baz.quux1
In the expression:
do let a = Foo {foo = ...}
- print $ ....quux
+ print @Quux $ ....quux1
+ let b = myQuux
+ print @Quux $ b.quux2
+ let c = Foo {foo = ...}
+ ...
-RecordDotSyntaxFail8.hs:37:11: error: [GHC-39999]
- • No instance for ‘HasField "quux" Quux a0’
- arising from selecting the field ‘quux’
- • In the second argument of ‘($)’, namely ‘....bar.baz.quux’
- In a stmt of a 'do' block: print $ ....baz.quux
+RecordDotSyntaxFail8.hs:50:17: error: [GHC-39999]
+ • No instance for ‘HasField "quux2" Quux Quux’
+ arising from selecting the field ‘quux2’
+ NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class.
+ • In the second argument of ‘($)’, namely ‘b.quux2’
+ In a stmt of a 'do' block: print @Quux $ b.quux2
In the expression:
do let a = Foo {foo = ...}
- print $ ....quux
- Suggested fix:
- NB: There is no field selector ‘quux :: Quux
- -> a0’ in scope for record type ‘Quux’
+ print @Quux $ ....quux1
+ let b = myQuux
+ print @Quux $ b.quux2
+ let c = Foo {foo = ...}
+ ...
+
+RecordDotSyntaxFail8.hs:53:17: error: [GHC-39999]
+ • No instance for ‘HasField "quux3" Quux r0’
+ arising from selecting the field ‘quux3’
+ NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class.
+ • In the expression: ....bar.baz.quux3
+ In the second argument of ‘($)’, namely ‘....baz.quux3.wob’
+ In a stmt of a 'do' block: print @Bool $ ....quux3.wob
=====================================
testsuite/tests/rename/should_fail/T19843h.stderr
=====================================
@@ -29,7 +29,7 @@ T19843h.hs:24:8: error: [GHC-39999]
• In the expression: undefined.getAll
In an equation for ‘quur’: quur = undefined.getAll
Suggested fixes:
- • Perhaps use record field of Alt ‘getAlt’ (imported from Data.Monoid)
• Add ‘getAll’ to the import list in the import of ‘Data.Monoid’
- (at T19843h.hs:9:1-28).
+ (at T19843h.hs:8:1-46).
+ • Perhaps use record field of Alt ‘getAlt’ (imported from Data.Monoid)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ef22fa0ba7c0a9284176e40fdc313…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ef22fa0ba7c0a9284176e40fdc313…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Add SIMD primops for bitwise logical operations
by Marge Bot (＠marge-bot) 27 Oct '25
by Marge Bot (＠marge-bot) 27 Oct '25
27 Oct '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6ef22fa0 by IC Rainbow at 2025-10-26T18:23:01-04:00
Add SIMD primops for bitwise logical operations
This adds 128-bit wide and/or/xor instructions for X86 NCG,
with both SSE and AVX encodings.
```
andFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -- andps / vandps
andDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -- andpd / vandpd
andInt8X16# :: Int8X16# -> Int8X16# -> Int8X16# -- pand / vpand
```
The new primops are available on ARM when using LLVM backend.
Tests added:
- simd015 (floats and doubles)
- simd016 (integers)
- simd017 (words)
Fixes #26417
- - - - -
26 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- docs/users_guide/9.16.1-notes.rst
- libraries/base/src/GHC/Base.hs
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-experimental/CHANGELOG.md
- libraries/ghc-prim/changelog.md
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- testsuite/tests/simd/should_run/all.T
- + testsuite/tests/simd/should_run/simd015.hs
- + testsuite/tests/simd/should_run/simd015.stdout
- + testsuite/tests/simd/should_run/simd016.hs
- + testsuite/tests/simd/should_run/simd016.stdout
- + testsuite/tests/simd/should_run/simd017.hs
- + testsuite/tests/simd/should_run/simd017.stdout
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -4391,6 +4391,24 @@ primop VecMaxOp "max#" GenPrimOp
with
vector = ALL_VECTOR_TYPES
+primop VecAndOp "and#" GenPrimOp
+ VECTOR -> VECTOR -> VECTOR
+ {Bit-wise AND of two vectors.}
+ with
+ vector = ALL_VECTOR_TYPES
+
+primop VecOrOp "or#" GenPrimOp
+ VECTOR -> VECTOR -> VECTOR
+ {Bit-wise OR of two vectors.}
+ with
+ vector = ALL_VECTOR_TYPES
+
+primop VecXorOp "xor#" GenPrimOp
+ VECTOR -> VECTOR -> VECTOR
+ {Bit-wise XOR of two vectors.}
+ with
+ vector = ALL_VECTOR_TYPES
+
------------------------------------------------------------------------
section "Prefetch"
=====================================
compiler/GHC/Cmm/MachOp.hs
=====================================
@@ -196,6 +196,14 @@ data MachOp
| MO_VF_Min Length Width
| MO_VF_Max Length Width
+ -- Bitwise vector operations
+ | MO_V_And Length Width
+ | MO_V_Or Length Width
+ | MO_V_Xor Length Width
+ | MO_VF_And Length Width
+ | MO_VF_Or Length Width
+ | MO_VF_Xor Length Width
+
-- | An atomic read with no memory ordering. Address msut
-- be naturally aligned.
| MO_RelaxedRead Width
@@ -507,6 +515,14 @@ machOpResultType platform mop tys =
MO_V_Sub l w -> cmmVec l (cmmBits w)
MO_V_Mul l w -> cmmVec l (cmmBits w)
+ MO_V_And l w -> cmmVec l (cmmBits w)
+ MO_V_Or l w -> cmmVec l (cmmBits w)
+ MO_V_Xor l w -> cmmVec l (cmmBits w)
+
+ MO_VF_And l w -> cmmVec l (cmmBits w)
+ MO_VF_Or l w -> cmmVec l (cmmBits w)
+ MO_VF_Xor l w -> cmmVec l (cmmBits w)
+
MO_VS_Neg l w -> cmmVec l (cmmBits w)
MO_VS_Min l w -> cmmVec l (cmmBits w)
MO_VS_Max l w -> cmmVec l (cmmBits w)
@@ -636,6 +652,13 @@ machOpArgReps platform op =
MO_VF_Min l w -> [vecwidth l w, vecwidth l w]
MO_VF_Max l w -> [vecwidth l w, vecwidth l w]
+ MO_V_And l w -> [vecwidth l w, vecwidth l w]
+ MO_V_Or l w -> [vecwidth l w, vecwidth l w]
+ MO_V_Xor l w -> [vecwidth l w, vecwidth l w]
+ MO_VF_And l w -> [vecwidth l w, vecwidth l w]
+ MO_VF_Or l w -> [vecwidth l w, vecwidth l w]
+ MO_VF_Xor l w -> [vecwidth l w, vecwidth l w]
+
MO_RelaxedRead _ -> [wordWidth platform]
MO_AlignmentCheck _ w -> [w]
where
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -832,6 +832,9 @@ getRegister' config plat expr
MO_V_Add {} -> notUnary
MO_V_Sub {} -> notUnary
MO_V_Mul {} -> notUnary
+ MO_V_And {} -> notUnary
+ MO_V_Or {} -> notUnary
+ MO_V_Xor {} -> notUnary
MO_VS_Neg {} -> notUnary
MO_V_Shuffle {} -> notUnary
MO_VF_Shuffle {} -> notUnary
@@ -841,6 +844,9 @@ getRegister' config plat expr
MO_VF_Sub {} -> notUnary
MO_VF_Mul {} -> notUnary
MO_VF_Quot {} -> notUnary
+ MO_VF_And {} -> notUnary
+ MO_VF_Or {} -> notUnary
+ MO_VF_Xor {} -> notUnary
MO_Add {} -> notUnary
MO_Sub {} -> notUnary
@@ -1221,6 +1227,12 @@ getRegister' config plat expr
MO_V_Add {} -> vectorsNeedLlvm
MO_V_Sub {} -> vectorsNeedLlvm
MO_V_Mul {} -> vectorsNeedLlvm
+ MO_V_And {} -> vectorsNeedLlvm
+ MO_V_Or {} -> vectorsNeedLlvm
+ MO_V_Xor {} -> vectorsNeedLlvm
+ MO_VF_And {} -> vectorsNeedLlvm
+ MO_VF_Or {} -> vectorsNeedLlvm
+ MO_VF_Xor {} -> vectorsNeedLlvm
MO_VS_Neg {} -> vectorsNeedLlvm
MO_VF_Extract {} -> vectorsNeedLlvm
MO_VF_Add {} -> vectorsNeedLlvm
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -1137,6 +1137,13 @@ getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
MO_VF_Min {} -> incorrectOperands
MO_VF_Max {} -> incorrectOperands
+ MO_V_And {} -> incorrectOperands
+ MO_V_Or {} -> incorrectOperands
+ MO_V_Xor {} -> incorrectOperands
+ MO_VF_And {} -> incorrectOperands
+ MO_VF_Or {} -> incorrectOperands
+ MO_VF_Xor {} -> incorrectOperands
+
MO_VF_Extract {} -> incorrectOperands
MO_VF_Add {} -> incorrectOperands
MO_VF_Sub {} -> incorrectOperands
@@ -1404,6 +1411,20 @@ getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
MO_VF_Max l w | avx -> vector_float_op_avx (VMINMAX Max FloatMinMax) l w x y
| otherwise -> vector_float_op_sse (MINMAX Max FloatMinMax) l w x y
+ MO_V_And l w | avx -> vector_int_op_avx VPAND l w x y
+ | otherwise -> vector_int_op_sse PAND l w x y
+ MO_V_Or l w | avx -> vector_int_op_avx VPOR l w x y
+ | otherwise -> vector_int_op_sse POR l w x y
+ MO_V_Xor l w | avx -> vector_int_op_avx VPXOR l w x y
+ | otherwise -> vector_int_op_sse PXOR l w x y
+
+ MO_VF_And l w | avx -> vector_float_op_avx VAND l w x y
+ | otherwise -> vector_float_op_sse (\fmt op2 -> AND fmt op2 . OpReg) l w x y
+ MO_VF_Or l w | avx -> vector_float_op_avx VOR l w x y
+ | otherwise -> vector_float_op_sse (\fmt op2 -> OR fmt op2 . OpReg) l w x y
+ MO_VF_Xor l w | avx -> vector_float_op_avx VXOR l w x y
+ | otherwise -> vector_float_op_sse (\fmt op2 -> XOR fmt op2 . OpReg) l w x y
+
-- SIMD NCG TODO: 256/512-bit integer vector operations
MO_V_Shuffle 16 W8 is | not is32Bit -> vector_shuffle_int8x16 sse4_1 x y is
MO_V_Shuffle 8 W16 is -> vector_shuffle_int16x8 sse4_1 x y is
@@ -1680,6 +1701,21 @@ getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
-----------------------
-- Vector operations---
+ vector_int_op_avx :: (Format -> Operand -> Reg -> Reg -> Instr)
+ -> Length
+ -> Width
+ -> CmmExpr
+ -> CmmExpr
+ -> NatM Register
+ vector_int_op_avx instr l w = vector_op_avx_reg (\fmt -> instr fmt . OpReg) format
+ where format = case w of
+ W8 -> VecFormat l FmtInt8
+ W16 -> VecFormat l FmtInt16
+ W32 -> VecFormat l FmtInt32
+ W64 -> VecFormat l FmtInt64
+ _ -> pprPanic "Integer AVX vector operation not supported at this width"
+ (text "width:" <+> ppr w)
+
vector_float_op_avx :: (Format -> Operand -> Reg -> Reg -> Instr)
-> Length
-> Width
@@ -3157,7 +3193,7 @@ getRegister' platform is32Bit (CmmLit lit) = do
| avx
= if float_or_floatvec
then unitOL (VXOR fmt (OpReg dst) dst dst)
- else unitOL (VPXOR fmt dst dst dst)
+ else unitOL (VPXOR fmt (OpReg dst) dst dst)
| otherwise
= if float_or_floatvec
then unitOL (XOR fmt (OpReg dst) (OpReg dst))
=====================================
compiler/GHC/CmmToAsm/X86/Instr.hs
=====================================
@@ -175,11 +175,13 @@ data Instr
| AND Format Operand Operand
| OR Format Operand Operand
| XOR Format Operand Operand
- -- | AVX bitwise logical XOR operation
- | VXOR Format Operand Reg Reg
| NOT Format Operand
| NEGI Format Operand -- NEG instruction (name clash with Cond)
| BSWAP Format Reg
+ -- Vector bitwise logical operations
+ | VAND Format Operand Reg Reg
+ | VOR Format Operand Reg Reg
+ | VXOR Format Operand Reg Reg
-- Shifts (amount may be immediate or %cl only)
| SHL Format Operand{-amount-} Operand
@@ -318,10 +320,12 @@ data Instr
-- logic operations
| PXOR Format Operand Reg
- | VPXOR Format Reg Reg Reg
+ | VPXOR Format Operand Reg Reg
| PAND Format Operand Reg
| PANDN Format Operand Reg
+ | VPAND Format Operand Reg Reg
| POR Format Operand Reg
+ | VPOR Format Operand Reg Reg
-- Arithmetic
| VADD Format Operand Reg Reg
@@ -444,8 +448,14 @@ regUsageOfInstr platform instr
IDIV fmt op -> mkRU (mk fmt eax:mk fmt edx:use_R fmt op []) [mk fmt eax, mk fmt edx]
ADD_CC fmt src dst -> usageRM fmt src dst
SUB_CC fmt src dst -> usageRM fmt src dst
+
AND fmt src dst -> usageRM fmt src dst
+ VAND fmt src1 src2 dst
+ -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]
+
OR fmt src dst -> usageRM fmt src dst
+ VOR fmt src1 src2 dst
+ -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]
XOR fmt (OpReg src) (OpReg dst)
| src == dst
@@ -500,6 +510,8 @@ regUsageOfInstr platform instr
LOCATION{} -> noUsage
UNWIND{} -> noUsage
DELTA _ -> noUsage
+ LDATA{} -> noUsage
+ NEWBLOCK{} -> noUsage
POPCNT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]
LZCNT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]
@@ -525,7 +537,7 @@ regUsageOfInstr platform instr
VPBROADCAST sFmt vFmt src dst -> mkRU (use_R sFmt src []) [mk vFmt dst]
VEXTRACT fmt _off src dst -> usageRW fmt (OpReg src) dst
INSERTPS fmt (ImmInt off) src dst
- -> mkRU ((use_R fmt src []) ++ [mk fmt dst | not doesNotReadDst]) [mk fmt dst]
+ -> mkRU (use_R fmt src [mk fmt dst | not doesNotReadDst]) [mk fmt dst]
where
-- Compute whether the instruction reads the destination register or not.
-- Immediate bits: ss_dd_zzzz s = src pos, d = dst pos, z = zeroed components.
@@ -534,7 +546,7 @@ regUsageOfInstr platform instr
-- are being zeroed.
where pos = ( off `shiftR` 4 ) .&. 0b11
INSERTPS fmt _off src dst
- -> mkRU ((use_R fmt src []) ++ [mk fmt dst]) [mk fmt dst]
+ -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
VINSERTPS fmt _imm src2 src1 dst
-> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]
PINSR sFmt vFmt _off src dst
@@ -550,26 +562,30 @@ regUsageOfInstr platform instr
VMOVDQU fmt src dst -> usageRW fmt src dst
VMOV_MERGE fmt src2 src1 dst -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]
- PXOR fmt (OpReg src) dst
- | src == dst
+ PXOR fmt src dst
+ | OpReg src_reg <- src
+ , src_reg == dst
-> mkRU [] [mk fmt dst]
| otherwise
- -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]
+ -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
VPXOR fmt s1 s2 dst
- | s1 == s2, s1 == dst
+ | OpReg s1_reg <- s1
+ , s1_reg == s2, s1_reg == dst
-> mkRU [] [mk fmt dst]
| otherwise
- -> mkRU [mk fmt s1, mk fmt s2] [mk fmt dst]
+ -> mkRU (use_R fmt s1 [mk fmt s2]) [mk fmt dst]
PAND fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
PANDN fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
+ VPAND fmt s1 s2 dst -> mkRU (use_R fmt s1 [mk fmt s2]) [mk fmt dst]
POR fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
+ VPOR fmt s1 s2 dst -> mkRU (use_R fmt s1 [mk fmt s2]) [mk fmt dst]
- VADD fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]
- VSUB fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]
- VMUL fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]
- VDIV fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]
+ VADD fmt s1 s2 dst -> mkRU (use_R fmt s1 [mk fmt s2]) [mk fmt dst]
+ VSUB fmt s1 s2 dst -> mkRU (use_R fmt s1 [mk fmt s2]) [mk fmt dst]
+ VMUL fmt s1 s2 dst -> mkRU (use_R fmt s1 [mk fmt s2]) [mk fmt dst]
+ VDIV fmt s1 s2 dst -> mkRU (use_R fmt s1 [mk fmt s2]) [mk fmt dst]
PADD fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
PSUB fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
PMULL fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
@@ -651,7 +667,6 @@ regUsageOfInstr platform instr
-> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
VMINMAX _ _ fmt src1 src2 dst
-> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]
- _other -> panic "regUsage: unrecognised instr"
where
-- # Definitions
@@ -779,6 +794,8 @@ patchRegsOfInstr platform instr env
AND fmt src dst -> patch2 (AND fmt) src dst
OR fmt src dst -> patch2 (OR fmt) src dst
XOR fmt src dst -> patch2 (XOR fmt) src dst
+ VAND fmt src1 src2 dst -> VAND fmt (patchOp src1) (env src2) (env dst)
+ VOR fmt src1 src2 dst -> VOR fmt (patchOp src1) (env src2) (env dst)
VXOR fmt src1 src2 dst -> VXOR fmt (patchOp src1) (env src2) (env dst)
NOT fmt op -> patch1 (NOT fmt) op
BSWAP fmt reg -> BSWAP fmt (env reg)
@@ -868,11 +885,13 @@ patchRegsOfInstr platform instr env
VMOVDQU fmt src dst -> VMOVDQU fmt (patchOp src) (patchOp dst)
VMOV_MERGE fmt src2 src1 dst -> VMOV_MERGE fmt (env src2) (env src1) (env dst)
- PXOR fmt src dst -> PXOR fmt (patchOp src) (env dst)
- VPXOR fmt s1 s2 dst -> VPXOR fmt (env s1) (env s2) (env dst)
- PAND fmt src dst -> PAND fmt (patchOp src) (env dst)
+ PXOR fmt src dst -> PXOR fmt (patchOp src) (env dst)
+ VPXOR fmt s1 s2 dst -> VPXOR fmt (patchOp s1) (env s2) (env dst)
+ PAND fmt src dst -> PAND fmt (patchOp src) (env dst)
+ VPAND fmt s1 s2 dst -> VPAND fmt (patchOp s1) (env s2) (env dst)
PANDN fmt src dst -> PANDN fmt (patchOp src) (env dst)
- POR fmt src dst -> POR fmt (patchOp src) (env dst)
+ POR fmt src dst -> POR fmt (patchOp src) (env dst)
+ VPOR fmt s1 s2 dst -> VPOR fmt (patchOp s1) (env s2) (env dst)
VADD fmt s1 s2 dst -> VADD fmt (patchOp s1) (env s2) (env dst)
VSUB fmt s1 s2 dst -> VSUB fmt (patchOp s1) (env s2) (env dst)
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -737,9 +737,15 @@ pprInstr platform i = case i of
AND format src dst
-> pprFormatOpOp (text "and") format src dst
+ VAND format src1 src2 dst
+ -> pprFormatOpRegReg (text "vand") format src1 src2 dst
+
OR format src dst
-> pprFormatOpOp (text "or") format src dst
+ VOR format src1 src2 dst
+ -> pprFormatOpRegReg (text "vor") format src1 src2 dst
+
XOR FF32 src dst
-> pprOpOp (text "xorps") FF32 src dst
@@ -753,7 +759,7 @@ pprInstr platform i = case i of
-> pprFormatOpOp (text "xor") format src dst
VXOR fmt src1 src2 dst
- -> pprVxor fmt src1 src2 dst
+ -> pprVXor fmt src1 src2 dst
POPCNT format src dst
-> pprOpOp (text "popcnt") format src (OpReg dst)
@@ -1036,13 +1042,17 @@ pprInstr platform i = case i of
PXOR format src dst
-> pprPXor (text "pxor") format src dst
VPXOR format s1 s2 dst
- -> pprXor (text "vpxor") format s1 s2 dst
+ -> pprVXor format s1 s2 dst
PAND format src dst
-> pprOpReg (text "pand") format src dst
+ VPAND format s1 s2 dst
+ -> pprOpRegReg (text "vpand") format s1 s2 dst
PANDN format src dst
-> pprOpReg (text "pandn") format src dst
POR format src dst
-> pprOpReg (text "por") format src dst
+ VPOR format s1 s2 dst
+ -> pprOpRegReg (text "vpor") format s1 s2 dst
VEXTRACT format offset from to
-> pprFormatImmRegOp (text "vextract") format offset from to
INSERTPS format offset addr dst
@@ -1299,6 +1309,16 @@ pprInstr platform i = case i of
pprReg platform (archWordFormat (target32Bit platform)) reg
]
+ pprOpRegReg :: Line doc -> Format -> Operand -> Reg -> Reg -> doc
+ pprOpRegReg name format op1 reg2 reg3
+ = line $ hcat [
+ pprMnemonic_ name,
+ pprOperand platform format op1,
+ comma,
+ pprReg platform (archWordFormat (target32Bit platform)) reg2,
+ comma,
+ pprReg platform (archWordFormat (target32Bit platform)) reg3
+ ]
pprFormatOpReg :: Line doc -> Format -> Operand -> Reg -> doc
pprFormatOpReg name format op1 reg2
@@ -1397,17 +1417,6 @@ pprInstr platform i = case i of
pprReg platform vectorFormat dst
]
- pprXor :: Line doc -> Format -> Reg -> Reg -> Reg -> doc
- pprXor name format reg1 reg2 reg3
- = line $ hcat [
- pprGenMnemonic name format,
- pprReg platform format reg1,
- comma,
- pprReg platform format reg2,
- comma,
- pprReg platform format reg3
- ]
-
pprPXor :: Line doc -> Format -> Operand -> Reg -> doc
pprPXor name format src dst
= line $ hcat [
@@ -1417,8 +1426,8 @@ pprInstr platform i = case i of
pprReg platform format dst
]
- pprVxor :: Format -> Operand -> Reg -> Reg -> doc
- pprVxor fmt src1 src2 dst
+ pprVXor :: Format -> Operand -> Reg -> Reg -> doc
+ pprVXor fmt src1 src2 dst
= line $ hcat [
pprGenMnemonic mem fmt,
pprOperand platform fmt src1,
@@ -1433,7 +1442,8 @@ pprInstr platform i = case i of
FF64 -> text "vxorpd"
VecFormat _ FmtFloat -> text "vxorps"
VecFormat _ FmtDouble -> text "vxorpd"
- _ -> pprPanic "GHC.CmmToAsm.X86.Ppr.pprVxor: element type must be Float or Double"
+ VecFormat _ _ints -> text "vpxor"
+ _ -> pprPanic "GHC.CmmToAsm.X86.Ppr.pprVXor: unexpected format"
(ppr fmt)
pprInsert :: Line doc -> Format -> Imm -> Operand -> Reg -> doc
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -873,6 +873,31 @@ pprMachOp_for_C platform mop = case mop of
(text "MO_V_Mul")
(panic $ "PprC.pprMachOp_for_C: MO_V_Mul"
++ "unsupported by the unregisterised backend")
+ MO_V_And {} -> pprTrace "offending mop:"
+ (text "MO_V_And")
+ (panic $ "PprC.pprMachOp_for_C: MO_V_And"
+ ++ "unsupported by the unregisterised backend")
+ MO_V_Or {} -> pprTrace "offending mop:"
+ (text "MO_V_Or")
+ (panic $ "PprC.pprMachOp_for_C: MO_V_Or"
+ ++ "unsupported by the unregisterised backend")
+ MO_V_Xor {} -> pprTrace "offending mop:"
+ (text "MO_V_Xor")
+ (panic $ "PprC.pprMachOp_for_C: MO_V_Xor"
+ ++ "unsupported by the unregisterised backend")
+ MO_VF_And {} -> pprTrace "offending mop:"
+ (text "MO_VF_And")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_And"
+ ++ "unsupported by the unregisterised backend")
+ MO_VF_Or {} -> pprTrace "offending mop:"
+ (text "MO_VF_Or")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_Or"
+ ++ "unsupported by the unregisterised backend")
+ MO_VF_Xor {} -> pprTrace "offending mop:"
+ (text "MO_VF_Xor")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_Xor"
+ ++ "unsupported by the unregisterised backend")
+
MO_VS_Neg {} -> pprTrace "offending mop:"
(text "MO_VS_Neg")
(panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -1593,6 +1593,14 @@ genMachOp _ op [x] = case op of
MO_VF_Min _ _ -> panicOp
MO_VF_Max _ _ -> panicOp
+ MO_V_And {} -> panicOp
+ MO_V_Or {} -> panicOp
+ MO_V_Xor {} -> panicOp
+
+ MO_VF_And {} -> panicOp
+ MO_VF_Or {} -> panicOp
+ MO_VF_Xor {} -> panicOp
+
where
negate ty v2 negOp = do
(vx, stmts, top) <- exprToVar x
@@ -1754,11 +1762,19 @@ genMachOp_slow opt op [x, y] = case op of
MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
+ MO_V_And l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_And
+ MO_V_Or l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Or
+ MO_V_Xor l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Xor
+
MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
+ MO_VF_And l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_And
+ MO_VF_Or l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Or
+ MO_VF_Xor l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Xor
+
MO_Not _ -> panicOp
MO_S_Neg _ -> panicOp
MO_F_Neg _ -> panicOp
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1558,6 +1558,16 @@ emitPrimOp cfg primop =
| not allowIntWord64X2MinMax -> opCallish MO_W64X2_Max
(VecMaxOp WordVec n w) -> opTranslate (MO_VU_Max n w)
+ -- Vector bitwise instructions
+ -- On floats, ANDPS-like
+ (VecAndOp FloatVec n w) -> opTranslate (MO_VF_And n w)
+ (VecOrOp FloatVec n w) -> opTranslate (MO_VF_Or n w)
+ (VecXorOp FloatVec n w) -> opTranslate (MO_VF_Xor n w)
+ -- On integer, PAND-like
+ (VecAndOp _ n w) -> opTranslate (MO_V_And n w)
+ (VecOrOp _ n w) -> opTranslate (MO_V_Or n w)
+ (VecXorOp _ n w) -> opTranslate (MO_V_Xor n w)
+
-- Vector FMA instructions
VecFMAdd _ n w -> fmaOp FMAdd n w
VecFMSub _ n w -> fmaOp FMSub n w
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1211,6 +1211,9 @@ genPrim prof bound ty op = case op of
VecShuffleOp _ _ _ -> unhandledPrimop op
VecMinOp {} -> unhandledPrimop op
VecMaxOp {} -> unhandledPrimop op
+ VecAndOp {} -> unhandledPrimop op
+ VecOrOp {} -> unhandledPrimop op
+ VecXorOp {} -> unhandledPrimop op
PrefetchByteArrayOp3 -> noOp
PrefetchMutableByteArrayOp3 -> noOp
=====================================
docs/users_guide/9.16.1-notes.rst
=====================================
@@ -85,6 +85,8 @@ Cmm
``ghc-experimental`` library
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+- New SIMD primops for bitwise logical operations on 128-wide vectors.
+
``template-haskell`` library
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
libraries/base/src/GHC/Base.hs
=====================================
@@ -270,6 +270,97 @@ import GHC.Prim hiding
, minWord8X16#
, minWord8X32#
, minWord8X64#
+ -- Don't re-export vector logical primops
+ , andDoubleX2#
+ , andDoubleX4#
+ , andDoubleX8#
+ , andFloatX16#
+ , andFloatX4#
+ , andFloatX8#
+ , andInt16X16#
+ , andInt16X32#
+ , andInt16X8#
+ , andInt32X16#
+ , andInt32X4#
+ , andInt32X8#
+ , andInt64X2#
+ , andInt64X4#
+ , andInt64X8#
+ , andInt8X16#
+ , andInt8X32#
+ , andInt8X64#
+ , andWord16X16#
+ , andWord16X32#
+ , andWord16X8#
+ , andWord32X16#
+ , andWord32X4#
+ , andWord32X8#
+ , andWord64X2#
+ , andWord64X4#
+ , andWord64X8#
+ , andWord8X16#
+ , andWord8X32#
+ , andWord8X64#
+ , orDoubleX2#
+ , orDoubleX4#
+ , orDoubleX8#
+ , orFloatX16#
+ , orFloatX4#
+ , orFloatX8#
+ , orInt16X16#
+ , orInt16X32#
+ , orInt16X8#
+ , orInt32X16#
+ , orInt32X4#
+ , orInt32X8#
+ , orInt64X2#
+ , orInt64X4#
+ , orInt64X8#
+ , orInt8X16#
+ , orInt8X32#
+ , orInt8X64#
+ , orWord16X16#
+ , orWord16X32#
+ , orWord16X8#
+ , orWord32X16#
+ , orWord32X4#
+ , orWord32X8#
+ , orWord64X2#
+ , orWord64X4#
+ , orWord64X8#
+ , orWord8X16#
+ , orWord8X32#
+ , orWord8X64#
+ , xorDoubleX2#
+ , xorDoubleX4#
+ , xorDoubleX8#
+ , xorFloatX16#
+ , xorFloatX4#
+ , xorFloatX8#
+ , xorInt16X16#
+ , xorInt16X32#
+ , xorInt16X8#
+ , xorInt32X16#
+ , xorInt32X4#
+ , xorInt32X8#
+ , xorInt64X2#
+ , xorInt64X4#
+ , xorInt64X8#
+ , xorInt8X16#
+ , xorInt8X32#
+ , xorInt8X64#
+ , xorWord16X16#
+ , xorWord16X32#
+ , xorWord16X8#
+ , xorWord32X16#
+ , xorWord32X4#
+ , xorWord32X8#
+ , xorWord64X2#
+ , xorWord64X4#
+ , xorWord64X8#
+ , xorWord8X16#
+ , xorWord8X32#
+ , xorWord8X64#
)
import GHC.Prim.Ext
=====================================
libraries/base/src/GHC/Exts.hs
=====================================
@@ -245,6 +245,97 @@ import GHC.Prim hiding
, minWord8X16#
, minWord8X32#
, minWord8X64#
+ -- Don't re-export vector logical primops
+ , andDoubleX2#
+ , andDoubleX4#
+ , andDoubleX8#
+ , andFloatX16#
+ , andFloatX4#
+ , andFloatX8#
+ , andInt16X16#
+ , andInt16X32#
+ , andInt16X8#
+ , andInt32X16#
+ , andInt32X4#
+ , andInt32X8#
+ , andInt64X2#
+ , andInt64X4#
+ , andInt64X8#
+ , andInt8X16#
+ , andInt8X32#
+ , andInt8X64#
+ , andWord16X16#
+ , andWord16X32#
+ , andWord16X8#
+ , andWord32X16#
+ , andWord32X4#
+ , andWord32X8#
+ , andWord64X2#
+ , andWord64X4#
+ , andWord64X8#
+ , andWord8X16#
+ , andWord8X32#
+ , andWord8X64#
+ , orDoubleX2#
+ , orDoubleX4#
+ , orDoubleX8#
+ , orFloatX16#
+ , orFloatX4#
+ , orFloatX8#
+ , orInt16X16#
+ , orInt16X32#
+ , orInt16X8#
+ , orInt32X16#
+ , orInt32X4#
+ , orInt32X8#
+ , orInt64X2#
+ , orInt64X4#
+ , orInt64X8#
+ , orInt8X16#
+ , orInt8X32#
+ , orInt8X64#
+ , orWord16X16#
+ , orWord16X32#
+ , orWord16X8#
+ , orWord32X16#
+ , orWord32X4#
+ , orWord32X8#
+ , orWord64X2#
+ , orWord64X4#
+ , orWord64X8#
+ , orWord8X16#
+ , orWord8X32#
+ , orWord8X64#
+ , xorDoubleX2#
+ , xorDoubleX4#
+ , xorDoubleX8#
+ , xorFloatX16#
+ , xorFloatX4#
+ , xorFloatX8#
+ , xorInt16X16#
+ , xorInt16X32#
+ , xorInt16X8#
+ , xorInt32X16#
+ , xorInt32X4#
+ , xorInt32X8#
+ , xorInt64X2#
+ , xorInt64X4#
+ , xorInt64X8#
+ , xorInt8X16#
+ , xorInt8X32#
+ , xorInt8X64#
+ , xorWord16X16#
+ , xorWord16X32#
+ , xorWord16X8#
+ , xorWord32X16#
+ , xorWord32X4#
+ , xorWord32X8#
+ , xorWord64X2#
+ , xorWord64X4#
+ , xorWord64X8#
+ , xorWord8X16#
+ , xorWord8X32#
+ , xorWord8X64#
)
import GHC.Prim.Ext
=====================================
libraries/ghc-experimental/CHANGELOG.md
=====================================
@@ -1,5 +1,10 @@
# Revision history for ghc-experimental
+## 9.1601.0
+
+- New and/or/xor SIMD primops for bitwise logical operations, such as andDoubleX4#, orWord32X4#, xorInt8X16#, etc.
+ These are supported by the LLVM backend and by the X86_64 NCG backend (for the latter, only for 128-wide vectors).
+
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.
=====================================
libraries/ghc-prim/changelog.md
=====================================
@@ -1,3 +1,10 @@
+## 0.14.0
+
+- Shipped with GHC 9.16.1
+
+- New and/or/xor SIMD primops for bitwise logical operations, such as andDoubleX4#, orWord32X4#, xorInt8X16#, etc.
+ These are supported by the LLVM backend and by the X86_64 NCG backend (for the latter, only for 128-wide vectors).
+
## 0.13.1
- Shipped with GHC 9.14.1
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -4747,10 +4747,40 @@ module GHC.PrimOps where
addrToAny# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)). Addr# -> (# a #)
and# :: Word# -> Word# -> Word#
and64# :: Word64# -> Word64# -> Word64#
+ andDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ andDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ andDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ andFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ andFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ andFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
andI# :: Int# -> Int# -> Int#
+ andInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ andInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ andInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ andInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ andInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ andInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ andInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ andInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ andInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ andInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ andInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ andInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
andWord16# :: Word16# -> Word16# -> Word16#
+ andWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ andWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ andWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
andWord32# :: Word32# -> Word32# -> Word32#
+ andWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ andWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ andWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ andWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ andWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ andWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
andWord8# :: Word8# -> Word8# -> Word8#
+ andWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ andWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ andWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
annotateStack# :: forall {q :: RuntimeRep} b d (a :: TYPE q). b -> (State# d -> (# State# d, a #)) -> State# d -> (# State# d, a #)
anyToAddr# :: forall a. a -> State# RealWorld -> (# State# RealWorld, Addr# #)
asinDouble# :: Double# -> Double#
@@ -5458,10 +5488,40 @@ module GHC.PrimOps where
oneShot :: forall {q :: RuntimeRep} {r :: RuntimeRep} (a :: TYPE q) (b :: TYPE r). (a -> b) -> a -> b
or# :: Word# -> Word# -> Word#
or64# :: Word64# -> Word64# -> Word64#
+ orDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ orDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ orDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ orFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ orFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ orFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
orI# :: Int# -> Int# -> Int#
+ orInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ orInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ orInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ orInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ orInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ orInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ orInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ orInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ orInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ orInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ orInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ orInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
orWord16# :: Word16# -> Word16# -> Word16#
+ orWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ orWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ orWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
orWord32# :: Word32# -> Word32# -> Word32#
+ orWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ orWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ orWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ orWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ orWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ orWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
orWord8# :: Word8# -> Word8# -> Word8#
+ orWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ orWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ orWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
ord# :: Char# -> Int#
packDoubleX2# :: (# Double#, Double# #) -> DoubleX2#
packDoubleX4# :: (# Double#, Double#, Double#, Double# #) -> DoubleX4#
@@ -6271,10 +6331,40 @@ module GHC.PrimOps where
writeWordOffAddr# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d
xor# :: Word# -> Word# -> Word#
xor64# :: Word64# -> Word64# -> Word64#
+ xorDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ xorDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ xorDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ xorFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ xorFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ xorFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
xorI# :: Int# -> Int# -> Int#
+ xorInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ xorInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ xorInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ xorInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ xorInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ xorInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ xorInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ xorInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ xorInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ xorInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ xorInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ xorInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
xorWord16# :: Word16# -> Word16# -> Word16#
+ xorWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ xorWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ xorWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
xorWord32# :: Word32# -> Word32# -> Word32#
+ xorWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ xorWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ xorWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ xorWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ xorWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ xorWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
xorWord8# :: Word8# -> Word8# -> Word8#
+ xorWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ xorWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ xorWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
yield# :: State# RealWorld -> State# RealWorld
type (~) :: forall k. k -> k -> Constraint
class (a ~ b) => (~) a b
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -4747,10 +4747,40 @@ module GHC.PrimOps where
addrToAny# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)). Addr# -> (# a #)
and# :: Word# -> Word# -> Word#
and64# :: Word64# -> Word64# -> Word64#
+ andDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ andDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ andDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ andFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ andFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ andFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
andI# :: Int# -> Int# -> Int#
+ andInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ andInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ andInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ andInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ andInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ andInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ andInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ andInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ andInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ andInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ andInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ andInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
andWord16# :: Word16# -> Word16# -> Word16#
+ andWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ andWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ andWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
andWord32# :: Word32# -> Word32# -> Word32#
+ andWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ andWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ andWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ andWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ andWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ andWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
andWord8# :: Word8# -> Word8# -> Word8#
+ andWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ andWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ andWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
annotateStack# :: forall {q :: RuntimeRep} b d (a :: TYPE q). b -> (State# d -> (# State# d, a #)) -> State# d -> (# State# d, a #)
anyToAddr# :: forall a. a -> State# RealWorld -> (# State# RealWorld, Addr# #)
asinDouble# :: Double# -> Double#
@@ -5461,10 +5491,40 @@ module GHC.PrimOps where
oneShot :: forall {q :: RuntimeRep} {r :: RuntimeRep} (a :: TYPE q) (b :: TYPE r). (a -> b) -> a -> b
or# :: Word# -> Word# -> Word#
or64# :: Word64# -> Word64# -> Word64#
+ orDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ orDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ orDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ orFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ orFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ orFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
orI# :: Int# -> Int# -> Int#
+ orInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ orInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ orInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ orInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ orInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ orInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ orInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ orInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ orInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ orInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ orInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ orInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
orWord16# :: Word16# -> Word16# -> Word16#
+ orWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ orWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ orWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
orWord32# :: Word32# -> Word32# -> Word32#
+ orWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ orWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ orWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ orWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ orWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ orWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
orWord8# :: Word8# -> Word8# -> Word8#
+ orWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ orWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ orWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
ord# :: Char# -> Int#
packDoubleX2# :: (# Double#, Double# #) -> DoubleX2#
packDoubleX4# :: (# Double#, Double#, Double#, Double# #) -> DoubleX4#
@@ -6274,10 +6334,40 @@ module GHC.PrimOps where
writeWordOffAddr# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d
xor# :: Word# -> Word# -> Word#
xor64# :: Word64# -> Word64# -> Word64#
+ xorDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ xorDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ xorDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ xorFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ xorFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ xorFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
xorI# :: Int# -> Int# -> Int#
+ xorInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ xorInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ xorInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ xorInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ xorInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ xorInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ xorInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ xorInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ xorInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ xorInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ xorInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ xorInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
xorWord16# :: Word16# -> Word16# -> Word16#
+ xorWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ xorWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ xorWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
xorWord32# :: Word32# -> Word32# -> Word32#
+ xorWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ xorWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ xorWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ xorWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ xorWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ xorWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
xorWord8# :: Word8# -> Word8# -> Word8#
+ xorWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ xorWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ xorWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
yield# :: State# RealWorld -> State# RealWorld
type (~) :: forall k. k -> k -> Constraint
class (a ~ b) => (~) a b
=====================================
testsuite/tests/interface-stability/ghc-prim-exports.stdout
=====================================
@@ -1423,10 +1423,40 @@ module GHC.Prim where
addrToAny# :: forall {l :: GHC.Internal.Types.Levity} (a :: TYPE (GHC.Internal.Types.BoxedRep l)). Addr# -> (# a #)
and# :: Word# -> Word# -> Word#
and64# :: Word64# -> Word64# -> Word64#
+ andDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ andDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ andDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ andFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ andFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ andFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
andI# :: Int# -> Int# -> Int#
+ andInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ andInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ andInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ andInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ andInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ andInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ andInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ andInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ andInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ andInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ andInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ andInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
andWord16# :: Word16# -> Word16# -> Word16#
+ andWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ andWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ andWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
andWord32# :: Word32# -> Word32# -> Word32#
+ andWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ andWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ andWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ andWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ andWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ andWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
andWord8# :: Word8# -> Word8# -> Word8#
+ andWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ andWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ andWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
annotateStack# :: forall {q :: GHC.Internal.Types.RuntimeRep} b d (a :: TYPE q). b -> (State# d -> (# State# d, a #)) -> State# d -> (# State# d, a #)
anyToAddr# :: forall a. a -> State# RealWorld -> (# State# RealWorld, Addr# #)
asinDouble# :: Double# -> Double#
@@ -2111,10 +2141,40 @@ module GHC.Prim where
numSparks# :: forall d. State# d -> (# State# d, Int# #)
or# :: Word# -> Word# -> Word#
or64# :: Word64# -> Word64# -> Word64#
+ orDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ orDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ orDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ orFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ orFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ orFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
orI# :: Int# -> Int# -> Int#
+ orInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ orInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ orInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ orInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ orInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ orInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ orInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ orInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ orInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ orInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ orInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ orInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
orWord16# :: Word16# -> Word16# -> Word16#
+ orWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ orWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ orWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
orWord32# :: Word32# -> Word32# -> Word32#
+ orWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ orWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ orWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ orWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ orWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ orWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
orWord8# :: Word8# -> Word8# -> Word8#
+ orWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ orWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ orWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
ord# :: Char# -> Int#
packDoubleX2# :: (# Double#, Double# #) -> DoubleX2#
packDoubleX4# :: (# Double#, Double#, Double#, Double# #) -> DoubleX4#
@@ -2886,10 +2946,40 @@ module GHC.Prim where
writeWordOffAddr# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d
xor# :: Word# -> Word# -> Word#
xor64# :: Word64# -> Word64# -> Word64#
+ xorDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ xorDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ xorDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ xorFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ xorFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ xorFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
xorI# :: Int# -> Int# -> Int#
+ xorInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ xorInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ xorInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ xorInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ xorInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ xorInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ xorInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ xorInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ xorInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ xorInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ xorInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ xorInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
xorWord16# :: Word16# -> Word16# -> Word16#
+ xorWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ xorWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ xorWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
xorWord32# :: Word32# -> Word32# -> Word32#
+ xorWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ xorWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ xorWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ xorWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ xorWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ xorWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
xorWord8# :: Word8# -> Word8# -> Word8#
+ xorWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ xorWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ xorWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
yield# :: State# RealWorld -> State# RealWorld
module GHC.Prim.Exception where
=====================================
testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
=====================================
@@ -1423,10 +1423,40 @@ module GHC.Prim where
addrToAny# :: forall {l :: GHC.Internal.Types.Levity} (a :: TYPE (GHC.Internal.Types.BoxedRep l)). Addr# -> (# a #)
and# :: Word# -> Word# -> Word#
and64# :: Word64# -> Word64# -> Word64#
+ andDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ andDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ andDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ andFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ andFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ andFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
andI# :: Int# -> Int# -> Int#
+ andInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ andInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ andInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ andInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ andInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ andInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ andInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ andInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ andInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ andInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ andInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ andInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
andWord16# :: Word16# -> Word16# -> Word16#
+ andWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ andWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ andWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
andWord32# :: Word32# -> Word32# -> Word32#
+ andWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ andWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ andWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ andWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ andWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ andWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
andWord8# :: Word8# -> Word8# -> Word8#
+ andWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ andWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ andWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
annotateStack# :: forall {q :: GHC.Internal.Types.RuntimeRep} b d (a :: TYPE q). b -> (State# d -> (# State# d, a #)) -> State# d -> (# State# d, a #)
anyToAddr# :: forall a. a -> State# RealWorld -> (# State# RealWorld, Addr# #)
asinDouble# :: Double# -> Double#
@@ -2111,10 +2141,40 @@ module GHC.Prim where
numSparks# :: forall d. State# d -> (# State# d, Int# #)
or# :: Word# -> Word# -> Word#
or64# :: Word64# -> Word64# -> Word64#
+ orDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ orDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ orDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ orFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ orFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ orFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
orI# :: Int# -> Int# -> Int#
+ orInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ orInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ orInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ orInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ orInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ orInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ orInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ orInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ orInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ orInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ orInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ orInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
orWord16# :: Word16# -> Word16# -> Word16#
+ orWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ orWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ orWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
orWord32# :: Word32# -> Word32# -> Word32#
+ orWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ orWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ orWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ orWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ orWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ orWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
orWord8# :: Word8# -> Word8# -> Word8#
+ orWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ orWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ orWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
ord# :: Char# -> Int#
packDoubleX2# :: (# Double#, Double# #) -> DoubleX2#
packDoubleX4# :: (# Double#, Double#, Double#, Double# #) -> DoubleX4#
@@ -2886,10 +2946,40 @@ module GHC.Prim where
writeWordOffAddr# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d
xor# :: Word# -> Word# -> Word#
xor64# :: Word64# -> Word64# -> Word64#
+ xorDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
+ xorDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
+ xorDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#
+ xorFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#
+ xorFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#
+ xorFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#
xorI# :: Int# -> Int# -> Int#
+ xorInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#
+ xorInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#
+ xorInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#
+ xorInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#
+ xorInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#
+ xorInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#
+ xorInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#
+ xorInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#
+ xorInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#
+ xorInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#
+ xorInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#
+ xorInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#
xorWord16# :: Word16# -> Word16# -> Word16#
+ xorWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#
+ xorWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#
+ xorWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#
xorWord32# :: Word32# -> Word32# -> Word32#
+ xorWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#
+ xorWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#
+ xorWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#
+ xorWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#
+ xorWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#
+ xorWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#
xorWord8# :: Word8# -> Word8# -> Word8#
+ xorWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
+ xorWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
+ xorWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
yield# :: State# RealWorld -> State# RealWorld
module GHC.Prim.Exception where
=====================================
testsuite/tests/simd/should_run/all.T
=====================================
@@ -92,6 +92,15 @@ test('simd014',
# of the XMM4 register, which may not be mapped to a real machine
# register on non-x86 architectures.
compile_and_run, ['simd014Cmm.cmm'])
+test('simd015',
+ [ when(have_llvm(), extra_ways(["optllvm"])) ],
+ compile_and_run, [''])
+test('simd016',
+ [ when(have_llvm(), extra_ways(["optllvm"])) ],
+ compile_and_run, [''])
+test('simd017',
+ [ when(have_llvm(), extra_ways(["optllvm"])) ],
+ compile_and_run, [''])
test('simd_insert', [], compile_and_run, [''])
test('simd_insert_array', [], compile_and_run, [''])
=====================================
testsuite/tests/simd/should_run/simd015.hs
=====================================
@@ -0,0 +1,45 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ExtendedLiterals #-}
+
+-- bitwise instructions on floating point vectors
+
+import GHC.Exts
+import GHC.Int
+import GHC.Prim
+
+
+main :: IO ()
+main = do
+ putStrLn "DoubleX2#"
+ let
+ !d1 = packDoubleX2# (# 1.1##, 2.2## #)
+ !d2 = packDoubleX2# (# 0.0##, 2.2## #)
+ !d3 = packDoubleX2# (# -5.5##, 32.0## #)
+ !d4 = packDoubleX2# (# 5.5##, 128.0## #)
+
+ case unpackDoubleX2# (andDoubleX2# d1 d2) of
+ (# a, b #) -> print (D# a, D# b)
+ case unpackDoubleX2# (andDoubleX2# d3 d4) of
+ (# c, d #) -> print (D# c, D# d)
+ case unpackDoubleX2# (orDoubleX2# d1 d2) of
+ (# a, b #) -> print (D# a, D# b)
+ case unpackDoubleX2# (orDoubleX2# d3 d4) of
+ (# c, d #) -> print (D# c, D# d)
+ case unpackDoubleX2# (xorDoubleX2# d1 d2) of
+ (# a, b #) -> print (D# a, D# b)
+ case unpackDoubleX2# (xorDoubleX2# d3 d4) of
+ (# c, d #) -> print (D# c, D# d)
+
+ putStrLn ""
+ putStrLn "FloatX4#"
+ let
+ !f1 = packFloatX4# (# 1.1#, 2.2#, -5.5#, 128.0# #)
+ !f2 = packFloatX4# (# 0.0#, 2.2#, 5.5#, 32.0# #)
+
+ case unpackFloatX4# (andFloatX4# f1 f2) of
+ (# a, b, c, d #) -> print (F# a, F# b, F# c, F# d)
+ case unpackFloatX4# (orFloatX4# f1 f2) of
+ (# a, b, c, d #) -> print (F# a, F# b, F# c, F# d)
+ case unpackFloatX4# (xorFloatX4# f1 f2) of
+ (# a, b, c, d #) -> print (F# a, F# b, F# c, F# d)
=====================================
testsuite/tests/simd/should_run/simd015.stdout
=====================================
@@ -0,0 +1,12 @@
+DoubleX2#
+(0.0,2.2)
+(5.5,32.0)
+(1.1,2.2)
+(-5.5,128.0)
+(1.1,0.0)
+(-0.0,4.450147717014403e-308)
+
+FloatX4#
+(0.0,2.2,5.5,32.0)
+(1.1,2.2,-5.5,128.0)
+(1.1,0.0,-0.0,2.3509887e-38)
=====================================
testsuite/tests/simd/should_run/simd016.hs
=====================================
@@ -0,0 +1,115 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ExtendedLiterals #-}
+
+-- bitwise instructions on signed integer vectors
+
+import GHC.Exts
+import GHC.Int
+import GHC.Prim
+
+
+main :: IO ()
+main = do
+ putStrLn "Int64X2#"
+ let
+ !i64_1 = packInt64X2# (# 1#Int64, 2#Int64 #)
+ !i64_2 = packInt64X2# (# 0#Int64, 2#Int64 #)
+ !i64_3 = packInt64X2# (# -5#Int64, 128#Int64 #)
+ !i64_4 = packInt64X2# (# 5#Int64, 32#Int64 #)
+
+ case unpackInt64X2# (andInt64X2# i64_1 i64_2) of
+ (# a, b #) -> print (I64# a, I64# b)
+ case unpackInt64X2# (andInt64X2# i64_3 i64_4) of
+ (# c, d #) -> print (I64# c, I64# d)
+ case unpackInt64X2# (orInt64X2# i64_1 i64_2) of
+ (# a, b #) -> print (I64# a, I64# b)
+ case unpackInt64X2# (orInt64X2# i64_3 i64_4) of
+ (# c, d #) -> print (I64# c, I64# d)
+ case unpackInt64X2# (xorInt64X2# i64_1 i64_2) of
+ (# a, b #) -> print (I64# a, I64# b)
+ case unpackInt64X2# (xorInt64X2# i64_3 i64_4) of
+ (# c, d #) -> print (I64# c, I64# d)
+
+ putStrLn ""
+ putStrLn "Int32X4#"
+ let
+ !i32_1 = packInt32X4# (# 1#Int32, 2#Int32, -5#Int32, 128#Int32 #)
+ !i32_2 = packInt32X4# (# 0#Int32, 2#Int32, 5#Int32, 32#Int32 #)
+
+ case unpackInt32X4# (andInt32X4# i32_1 i32_2) of
+ (# a, b, c, d #) -> print (I32# a, I32# b, I32# c, I32# d)
+ case unpackInt32X4# (orInt32X4# i32_1 i32_2) of
+ (# a, b, c, d #) -> print (I32# a, I32# b, I32# c, I32# d)
+ case unpackInt32X4# (xorInt32X4# i32_1 i32_2) of
+ (# a, b, c, d #) -> print (I32# a, I32# b, I32# c, I32# d)
+
+ putStrLn ""
+ putStrLn "Int16X8#"
+ let
+ !i16_1 = packInt16X8#
+ (# 1#Int16, 2#Int16, -5#Int16, 128#Int16
+ , 1#Int16, 2#Int16, -5#Int16, 128#Int16
+ #)
+ !i16_2 = packInt16X8#
+ (# 0#Int16, 2#Int16, 5#Int16, 32#Int16
+ , 0#Int16, 2#Int16, 5#Int16, 32#Int16
+ #)
+ case unpackInt16X8# (andInt16X8# i16_1 i16_2) of
+ (# a, b, c, d, e, f, g, h #) ->
+ print
+ ( (I16# a, I16# b, I16# c, I16# d)
+ , (I16# e, I16# f, I16# g, I16# h)
+ )
+ case unpackInt16X8# (orInt16X8# i16_1 i16_2) of
+ (# a, b, c, d, e, f, g, h #) ->
+ print
+ ( (I16# a, I16# b, I16# c, I16# d)
+ , (I16# e, I16# f, I16# g, I16# h)
+ )
+ case unpackInt16X8# (xorInt16X8# i16_1 i16_2) of
+ (# a, b, c, d, e, f, g, h #) ->
+ print
+ ( (I16# a, I16# b, I16# c, I16# d)
+ , (I16# e, I16# f, I16# g, I16# h)
+ )
+
+ putStrLn ""
+ putStrLn "Int8X16#"
+ let
+ !i8_1 = packInt8X16#
+ (# 1#Int8, 2#Int8, -5#Int8, 128#Int8
+ , 1#Int8, 2#Int8, -5#Int8, 128#Int8
+ , 1#Int8, 2#Int8, -5#Int8, 128#Int8
+ , 1#Int8, 2#Int8, -5#Int8, 128#Int8
+ #)
+ !i8_2 = packInt8X16#
+ (# 0#Int8, 2#Int8, 5#Int8, 32#Int8
+ , 0#Int8, 2#Int8, 5#Int8, 32#Int8
+ , 0#Int8, 2#Int8, 5#Int8, 32#Int8
+ , 0#Int8, 2#Int8, 5#Int8, 32#Int8
+ #)
+ case unpackInt8X16# (andInt8X16# i8_1 i8_2) of
+ (# a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p #) ->
+ print
+ ( (I8# a, I8# b, I8# c, I8# d)
+ , (I8# e, I8# f, I8# g, I8# h)
+ , (I8# i, I8# j, I8# k, I8# l)
+ , (I8# m, I8# n, I8# o, I8# p)
+ )
+ case unpackInt8X16# (orInt8X16# i8_1 i8_2) of
+ (# a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p #) ->
+ print
+ ( (I8# a, I8# b, I8# c, I8# d)
+ , (I8# e, I8# f, I8# g, I8# h)
+ , (I8# i, I8# j, I8# k, I8# l)
+ , (I8# m, I8# n, I8# o, I8# p)
+ )
+ case unpackInt8X16# (xorInt8X16# i8_1 i8_2) of
+ (# a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p #) ->
+ print
+ ( (I8# a, I8# b, I8# c, I8# d)
+ , (I8# e, I8# f, I8# g, I8# h)
+ , (I8# i, I8# j, I8# k, I8# l)
+ , (I8# m, I8# n, I8# o, I8# p)
+ )
=====================================
testsuite/tests/simd/should_run/simd016.stdout
=====================================
@@ -0,0 +1,22 @@
+Int64X2#
+(0,2)
+(1,0)
+(1,2)
+(-1,160)
+(1,0)
+(-2,160)
+
+Int32X4#
+(0,2,1,0)
+(1,2,-1,160)
+(1,0,-2,160)
+
+Int16X8#
+((0,2,1,0),(0,2,1,0))
+((1,2,-1,160),(1,2,-1,160))
+((1,0,-2,160),(1,0,-2,160))
+
+Int8X16#
+((0,2,1,0),(0,2,1,0),(0,2,1,0),(0,2,1,0))
+((1,2,-1,-96),(1,2,-1,-96),(1,2,-1,-96),(1,2,-1,-96))
+((1,0,-2,-96),(1,0,-2,-96),(1,0,-2,-96),(1,0,-2,-96))
=====================================
testsuite/tests/simd/should_run/simd017.hs
=====================================
@@ -0,0 +1,115 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ExtendedLiterals #-}
+
+-- bitwise instructions on unsigned integer vectors
+
+import GHC.Exts
+import GHC.Word
+import GHC.Prim
+
+
+main :: IO ()
+main = do
+ putStrLn "Word64X2#"
+ let
+ !w64_1 = packWord64X2# (# 1#Word64, 2#Word64 #)
+ !w64_2 = packWord64X2# (# 0#Word64, 2#Word64 #)
+ !w64_3 = packWord64X2# (# 18446744073709551615#Word64, 128#Word64 #)
+ !w64_4 = packWord64X2# (# 5#Word64, 32#Word64 #)
+
+ case unpackWord64X2# (andWord64X2# w64_1 w64_2) of
+ (# a, b #) -> print (W64# a, W64# b)
+ case unpackWord64X2# (andWord64X2# w64_3 w64_4) of
+ (# c, d #) -> print (W64# c, W64# d)
+ case unpackWord64X2# (orWord64X2# w64_1 w64_2) of
+ (# a, b #) -> print (W64# a, W64# b)
+ case unpackWord64X2# (orWord64X2# w64_3 w64_4) of
+ (# c, d #) -> print (W64# c, W64# d)
+ case unpackWord64X2# (xorWord64X2# w64_1 w64_2) of
+ (# a, b #) -> print (W64# a, W64# b)
+ case unpackWord64X2# (xorWord64X2# w64_3 w64_4) of
+ (# c, d #) -> print (W64# c, W64# d)
+
+ putStrLn ""
+ putStrLn "Word32X4#"
+ let
+ !w32_1 = packWord32X4# (# 1#Word32, 2#Word32, 4294967295#Word32, 128#Word32 #)
+ !w32_2 = packWord32X4# (# 0#Word32, 2#Word32, 5#Word32, 32#Word32 #)
+
+ case unpackWord32X4# (andWord32X4# w32_1 w32_2) of
+ (# a, b, c, d #) -> print (W32# a, W32# b, W32# c, W32# d)
+ case unpackWord32X4# (orWord32X4# w32_1 w32_2) of
+ (# a, b, c, d #) -> print (W32# a, W32# b, W32# c, W32# d)
+ case unpackWord32X4# (xorWord32X4# w32_1 w32_2) of
+ (# a, b, c, d #) -> print (W32# a, W32# b, W32# c, W32# d)
+
+ putStrLn ""
+ putStrLn "Word16X8#"
+ let
+ !w16_1 = packWord16X8#
+ (# 1#Word16, 2#Word16, 65535#Word16, 128#Word16
+ , 1#Word16, 2#Word16, 65535#Word16, 128#Word16
+ #)
+ !w16_2 = packWord16X8#
+ (# 0#Word16, 2#Word16, 5#Word16, 32#Word16
+ , 0#Word16, 2#Word16, 5#Word16, 32#Word16
+ #)
+ case unpackWord16X8# (andWord16X8# w16_1 w16_2) of
+ (# a, b, c, d, e, f, g, h #) ->
+ print
+ ( (W16# a, W16# b, W16# c, W16# d)
+ , (W16# e, W16# f, W16# g, W16# h)
+ )
+ case unpackWord16X8# (orWord16X8# w16_1 w16_2) of
+ (# a, b, c, d, e, f, g, h #) ->
+ print
+ ( (W16# a, W16# b, W16# c, W16# d)
+ , (W16# e, W16# f, W16# g, W16# h)
+ )
+ case unpackWord16X8# (xorWord16X8# w16_1 w16_2) of
+ (# a, b, c, d, e, f, g, h #) ->
+ print
+ ( (W16# a, W16# b, W16# c, W16# d)
+ , (W16# e, W16# f, W16# g, W16# h)
+ )
+
+ putStrLn ""
+ putStrLn "Word8X16#"
+ let
+ !w8_1 = packWord8X16#
+ (# 1#Word8, 2#Word8, 255#Word8, 128#Word8
+ , 1#Word8, 2#Word8, 255#Word8, 128#Word8
+ , 1#Word8, 2#Word8, 255#Word8, 128#Word8
+ , 1#Word8, 2#Word8, 255#Word8, 128#Word8
+ #)
+ !w8_2 = packWord8X16#
+ (# 0#Word8, 2#Word8, 5#Word8, 32#Word8
+ , 0#Word8, 2#Word8, 5#Word8, 32#Word8
+ , 0#Word8, 2#Word8, 5#Word8, 32#Word8
+ , 0#Word8, 2#Word8, 5#Word8, 32#Word8
+ #)
+ case unpackWord8X16# (andWord8X16# w8_1 w8_2) of
+ (# a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p #) ->
+ print
+ ( (W8# a, W8# b, W8# c, W8# d)
+ , (W8# e, W8# f, W8# g, W8# h)
+ , (W8# i, W8# j, W8# k, W8# l)
+ , (W8# m, W8# n, W8# o, W8# p)
+ )
+ case unpackWord8X16# (orWord8X16# w8_1 w8_2) of
+ (# a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p #) ->
+ print
+ ( (W8# a, W8# b, W8# c, W8# d)
+ , (W8# e, W8# f, W8# g, W8# h)
+ , (W8# i, W8# j, W8# k, W8# l)
+ , (W8# m, W8# n, W8# o, W8# p)
+ )
+ case unpackWord8X16# (xorWord8X16# w8_1 w8_2) of
+ (# a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p #) ->
+ print
+ ( (W8# a, W8# b, W8# c, W8# d)
+ , (W8# e, W8# f, W8# g, W8# h)
+ , (W8# i, W8# j, W8# k, W8# l)
+ , (W8# m, W8# n, W8# o, W8# p)
+ )
=====================================
testsuite/tests/simd/should_run/simd017.stdout
=====================================
@@ -0,0 +1,22 @@
+Word64X2#
+(0,2)
+(5,0)
+(1,2)
+(18446744073709551615,160)
+(1,0)
+(18446744073709551610,160)
+
+Word32X4#
+(0,2,5,0)
+(1,2,4294967295,160)
+(1,0,4294967290,160)
+
+Word16X8#
+((0,2,5,0),(0,2,5,0))
+((1,2,65535,160),(1,2,65535,160))
+((1,0,65530,160),(1,0,65530,160))
+
+Word8X16#
+((0,2,5,0),(0,2,5,0),(0,2,5,0),(0,2,5,0))
+((1,2,255,160),(1,2,255,160),(1,2,255,160),(1,2,255,160))
+((1,0,250,160),(1,0,250,160),(1,0,250,160),(1,0,250,160))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ef22fa0ba7c0a9284176e40fdc3135…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ef22fa0ba7c0a9284176e40fdc3135…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/int-index/reexport-ghc-hs-basic] Re-export GHC.Hs.Basic from GHC.Hs
by Vladislav Zavialov (＠int-index) 27 Oct '25
by Vladislav Zavialov (＠int-index) 27 Oct '25
27 Oct '25
Vladislav Zavialov pushed to branch wip/int-index/reexport-ghc-hs-basic at Glasgow Haskell Compiler / GHC
Commits:
51223e7c by Vladislav Zavialov at 2025-10-26T22:54:07+03:00
Re-export GHC.Hs.Basic from GHC.Hs
Clean up some import sections in GHC by re-exporting GHC.Hs.Basic
from GHC.Hs.
- - - - -
26 changed files:
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/HsToCore/Foreign/Wasm.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/ThToHs.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs.hs
=====================================
@@ -22,6 +22,7 @@ therefore, is almost nothing but re-exporting.
module GHC.Hs (
module Language.Haskell.Syntax,
+ module GHC.Hs.Basic,
module GHC.Hs.Binds,
module GHC.Hs.Decls,
module GHC.Hs.Expr,
@@ -33,7 +34,6 @@ module GHC.Hs (
module GHC.Hs.Doc,
module GHC.Hs.Extension,
module GHC.Parser.Annotation,
- Fixity,
HsModule(..), AnnsModule(..),
HsParsedModule(..), XModulePs(..)
@@ -42,6 +42,7 @@ module GHC.Hs (
-- friends:
import GHC.Prelude
+import GHC.Hs.Basic
import GHC.Hs.Decls
import GHC.Hs.Binds
import GHC.Hs.Expr
@@ -58,7 +59,6 @@ import GHC.Hs.Instances () -- For Data instances
-- others:
import GHC.Utils.Outputable
-import GHC.Types.Fixity ( Fixity )
import GHC.Types.SrcLoc
import GHC.Unit.Module.Warnings
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -121,11 +121,11 @@ import GHC.Hs.Doc
import GHC.Types.Basic
import GHC.Core.Coercion
+import GHC.Hs.Basic
import GHC.Hs.Extension
import GHC.Parser.Annotation
import GHC.Types.Name
import GHC.Types.Name.Set
-import GHC.Types.Fixity
-- others:
import GHC.Utils.Misc (count)
=====================================
compiler/GHC/HsToCore/Foreign/Wasm.hs
=====================================
@@ -45,7 +45,6 @@ import GHC.Types.Var
import GHC.Unit
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import Language.Haskell.Syntax.Basic
data Synchronicity = Sync | Async
deriving (Eq)
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -79,7 +79,6 @@ import GHC.Types.ForeignCall
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.SourceText
-import GHC.Types.Fixity
import GHC.Types.TyThing
import GHC.Types.Name hiding( varName, tcName )
import GHC.Types.Name.Env
@@ -89,8 +88,6 @@ import Data.Kind (Constraint)
import qualified GHC.LanguageExtensions as LangExt
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Data.ByteString ( unpack )
import Control.Monad
import Data.List (sort, sortBy)
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -45,8 +45,6 @@ module GHC.HsToCore.Utils (
import GHC.Prelude
-import Language.Haskell.Syntax.Basic (Boxity(..))
-
import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr )
=====================================
compiler/GHC/Parser/Errors/Types.hs
=====================================
@@ -6,7 +6,6 @@ module GHC.Parser.Errors.Types where
import GHC.Prelude
-import GHC.Core.TyCon (Role)
import GHC.Data.FastString
import GHC.Hs
import GHC.Parser.Types
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -134,7 +134,7 @@ import GHC.Hs -- Lots of it
import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import GHC.Core.DataCon ( DataCon, dataConTyCon, dataConName )
import GHC.Core.ConLike ( ConLike(..) )
-import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
+import GHC.Core.Coercion.Axiom ( fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Basic
@@ -170,8 +170,6 @@ import GHC.Unit.Module.Warnings
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -77,8 +77,6 @@ import GHC.Utils.Panic
import qualified GHC.LanguageExtensions as LangExt
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Control.Monad
import Data.List ( partition )
import Data.List.NonEmpty ( NonEmpty(..) )
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -62,8 +62,6 @@ module GHC.Rename.Env (
import GHC.Prelude
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import GHC.Iface.Load
import GHC.Iface.Env
import GHC.Hs
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -75,8 +75,6 @@ import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Control.Monad
import qualified Data.Foldable as Partial (maximum)
import Data.List (unzip4)
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -74,16 +74,13 @@ import GHC.Types.FieldLabel
import GHC.Types.Error
import GHC.Utils.Misc
-import GHC.Types.Fixity ( compareFixity, negateFixity
- , Fixity(..), FixityDirection(..), LexicalFixity(..) )
+import GHC.Types.Fixity ( compareFixity, negateFixity )
import GHC.Types.Basic ( TypeOrKind(..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Data.List (nubBy, partition)
import Control.Monad
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -65,7 +65,6 @@ import GHC.Rename.HsType
import GHC.Builtin.Names
import GHC.Types.Hint
-import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -53,7 +53,6 @@ import GHC.Tc.Utils.Monad
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
-import GHC.Core.DataCon
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.SourceFile
import GHC.Types.SourceText ( SourceText(..), IntegralLit )
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -91,8 +91,6 @@ import GHC.Data.Bag
import GHC.Data.Maybe ( expectJust )
import GHC.Unit.Module
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Data.List ( find, partition, intersperse )
-- | A declarative description of an auxiliary binding that should be
=====================================
compiler/GHC/Tc/Deriv/Generics.hs
=====================================
@@ -44,7 +44,6 @@ import GHC.Iface.Env ( newGlobalBinder )
import GHC.Types.Name hiding ( varName )
import GHC.Types.Name.Reader
-import GHC.Types.Fixity
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
@@ -62,8 +61,6 @@ import GHC.Utils.Misc
import GHC.Driver.DynFlags
import GHC.Data.FastString
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Control.Monad (mplus)
import Data.List (zip4, partition)
import Data.List.NonEmpty (NonEmpty (..), last, nonEmpty)
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -231,7 +231,7 @@ import GHC.Core.FamInstEnv (FamInst)
import GHC.Core.InstEnv (LookupInstanceErrReason, ClsInst, DFunId)
import GHC.Core.PatSyn (PatSyn)
import GHC.Core.Predicate (EqRel, predTypeEqRel)
-import GHC.Core.TyCon (TyCon, Role, FamTyConFlav, AlgTyConRhs)
+import GHC.Core.TyCon (TyCon, FamTyConFlav, AlgTyConRhs)
import GHC.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag, ForAllTyBinder)
import GHC.Driver.Backend (Backend)
@@ -245,8 +245,6 @@ import GHC.Data.FastString (FastString)
import GHC.Data.Pair
import GHC.Exception.Type (SomeException)
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Typeable (Typeable)
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -65,7 +65,6 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import qualified GHC.LanguageExtensions as LangExt
-import Language.Haskell.Syntax.Basic( isBoxed )
import Control.Monad
import Data.Function
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -27,8 +27,6 @@ module GHC.Tc.Gen.Expr
import GHC.Prelude
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import {-# SOURCE #-} GHC.Tc.Gen.Splice
( tcTypedSplice, tcTypedBracket, tcUntypedBracket, getUntypedSpliceBody )
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -59,7 +59,6 @@ import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Core.ConLike
import GHC.Builtin.Names
-import GHC.Types.Basic hiding (SuccessFlag(..))
import GHC.Driver.DynFlags
import GHC.Types.SrcLoc
import GHC.Types.Var.Set
@@ -73,7 +72,6 @@ import GHC.Data.FastString
import qualified Data.List.NonEmpty as NE
import GHC.Data.List.SetOps ( getNth )
-import Language.Haskell.Syntax.Basic (FieldLabelString(..), LexicalFixity(..))
import Data.List( partition )
import Control.Monad.Trans.Writer.CPS
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -105,8 +105,6 @@ import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Control.Monad
import Data.Foldable ( toList, traverse_ )
import Data.Functor.Identity
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -72,7 +72,6 @@ import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Basic
-import GHC.Types.Fixity
import GHC.Types.Id
import GHC.Types.SourceFile
import GHC.Types.SourceText
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -77,8 +77,6 @@ import GHC.Types.Unique.Set
import GHC.Types.TyThing
import qualified GHC.LanguageExtensions as LangExt
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Control.Monad
{-
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -85,8 +85,6 @@ import GHC.Utils.Misc( HasDebugCallStack, nTimes )
import GHC.Types.Unique
import GHC.Types.Unique.Supply
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import qualified Data.Kind as Hs
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (isNothing)
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -81,8 +81,6 @@ import GHC.Utils.Panic
import GHC.Data.List.SetOps
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Control.Monad
import Data.Foldable
import Data.Function
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -40,7 +40,6 @@ import qualified GHC.Core.Coercion as Coercion ( Role(..) )
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim( fUNTyCon )
import GHC.Types.Basic as Hs
-import GHC.Types.Fixity as Hs
import GHC.Types.ForeignCall
import GHC.Types.Unique
import GHC.Types.SourceText
@@ -53,8 +52,6 @@ import GHC.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.LanguageExtensions as LangExt
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import qualified Data.ByteString as BS
import Control.Monad( unless )
import Data.Bifunctor (first)
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -35,13 +35,11 @@ module ExactPrint
import GHC
import GHC.Base (NonEmpty(..))
-import GHC.Core.Coercion.Axiom (Role(..))
import qualified GHC.Data.BooleanFormula as BF
import GHC.Data.FastString
import qualified GHC.Data.Strict as Strict
import GHC.TypeLits
import GHC.Types.Basic hiding (EP)
-import GHC.Types.Fixity
import GHC.Types.ForeignCall
import GHC.Types.Name.Reader
import GHC.Types.PkgQual
@@ -53,8 +51,6 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Utils.Panic
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
import Control.Monad (forM, when, unless)
import Control.Monad.Identity (Identity(..))
import qualified Control.Monad.Reader as Reader
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/51223e7ce07e4d25d7ac02603b275cd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/51223e7ce07e4d25d7ac02603b275cd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Apoorv Ingle pushed to branch wip/ani/kill-popErrCtxt at Glasgow Haskell Compiler / GHC
Commits:
436d9f72 by Apoorv Ingle at 2025-10-26T14:00:30-05:00
wibbles
- - - - -
7 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/LclEnv.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -681,6 +681,7 @@ data SrcCodeOrigin
-- Does not presist post renaming phase
-- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
-- in `GHC.Tc.Gen.Do`
+ -- INVARIANT: SHOULD NEVER APPEAR IN A ExpansionCodeCtxt in CodeSrcFlag ErrCtxt on stack
data XXExprGhcRn
= ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.Concrete ( unifyConcrete, idConcreteTvs )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..), ErrCtxt (..) )
+import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..), ErrCtxt (..), CodeSrcFlag (..))
import GHC.Tc.Errors.Ppr (pprErrCtxtMsg)
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
@@ -951,28 +951,23 @@ addArgCtxt arg_no fun (L arg_loc arg) thing_inside
, text "arg: " <+> ppr (arg, arg_no)
, text "arg_loc:" <+> ppr arg_loc
, text "fun:" <+> ppr fun
- -- , text "err_ctx" <+> vcat (fmap (\ (x, y) -> case x of
- -- UserCodeCtxt{} -> text "<USER>" <+> pprErrCtxtMsg y
- -- ExpansionCodeCtxt{} -> text "<EXPN>" <+> pprErrCtxtMsg y)
- -- (take 4 (zip err_ctx err_ctx_msg)))
+ , text "err_ctx" <+> vcat (fmap (\ (x, y) -> case x of
+ MkErrCtxt (ExpansionCodeCtxt{}) _ -> text "<EXPN>" <+> pprErrCtxtMsg y
+ _ -> text "<USER>" <+> pprErrCtxtMsg y)
+ (take 4 (zip err_ctx err_ctx_msg)))
])
; if in_generated_code
- then updCtxtForArg (locA arg_loc) arg $
+ then updCtxtForArg (L arg_loc arg) $
thing_inside
else do setSrcSpanA arg_loc $
addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $
thing_inside }
where
- updCtxtForArg :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
- updCtxtForArg l@(RealSrcSpan{}) e thing_inside = -- See 2.iii above
- do setSrcSpan l $
- addExprCtxt e $
- thing_inside
- -- updCtxtForArg (UnhelpfulSpan UnhelpfulGenerated) _ thing_inside = -- See 2.i above
- -- thing_inside
- updCtxtForArg (UnhelpfulSpan {}) _ thing_inside = -- See 2.ii above
- do -- setInUserCode $
- thing_inside
+ updCtxtForArg :: LHsExpr GhcRn -> TcRn a -> TcRn a
+ updCtxtForArg e@(L lspan _) thing_inside
+ = do setSrcSpan (locA lspan) $
+ addLExprCtxt e $ -- addLExpr is no op for non-user located exprs
+ thing_inside
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -126,7 +126,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _))
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
- [ e -- Span is set because of statement loc
+ [ e
, expand_stmts_expr ]
return $ L loc (mkExpandedStmt stmt doFlavour expansion)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -54,7 +54,6 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Origin
-import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg )
import GHC.Tc.Types.Evidence
import GHC.Tc.Errors.Types hiding (HoleError)
@@ -125,7 +124,7 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
tcPolyLExpr (L loc expr) res_ty
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
- addExprCtxt expr $ -- Note [Error contexts in generated code]
+ addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code]
do { expr' <- tcPolyExpr expr res_ty
; return (L loc expr') }
@@ -244,7 +243,7 @@ tcInferRhoNC = tcInferExprNC IIF_DeepRho
tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferExpr iif (L loc expr)
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
- addExprCtxt expr $ -- Note [Error contexts in generated code]
+ addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code]
do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr)
; return (L loc expr', rho) }
@@ -271,7 +270,7 @@ tcMonoLExpr, tcMonoLExprNC
tcMonoLExpr (L loc expr) res_ty
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
- addExprCtxt expr $ -- Note [Error contexts in generated code]
+ addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code]
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
@@ -757,11 +756,8 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcXExpr (ExpandedThingRn o e) res_ty
- = addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $
- -- e is the expanded expression of o, so we need to set the error ctxt to generated
- -- see Note [Error Context Stack] in `GHC.Tc.Type.LclEnv`
- mkExpandedTc o <$> -- necessary for hpc ticks
- tcExpr e res_ty
+ = mkExpandedTc o <$> -- necessary for hpc ticks
+ tcExpr e res_ty
-- For record selection, same as HsVar case
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -26,7 +26,7 @@ module GHC.Tc.Gen.Head
, nonBidirectionalErr
, pprArgInst
- , addExprCtxt, addFunResCtxt ) where
+ , addExprCtxt, addLExprCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
@@ -1108,6 +1108,29 @@ addExprCtxt e thing_inside
-- f x = _
-- when we don't want to say "In the expression: _",
-- because it is mentioned in the error message itself
- XExpr{} -> thing_inside -- the err ctxt management done is done by setInGeneratedCode
- HsPar{} -> thing_inside -- the err ctxt management done is done by setInGeneratedCode
+ HsPar{} -> thing_inside -- We don't want to say 'In the expression (e)', we just want to say 'In the expression, 'e'. which will be handeled by the recursive call in thing_inside
+ XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) thing_inside
_ -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code
+
+
+addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a
+addLExprCtxt (L lspan e) thing_inside
+ | (RealSrcSpan{}) <- locA lspan
+ = case e of
+ HsHole _
+ -- The HsHole special case addresses situations like
+ -- f x = _
+ -- when we don't want to say "In the expression: _",
+ -- because it is mentioned in the error message itself
+ -> thing_inside
+ HsPar{}
+ -- We don't want to say 'In the expression (e)',
+ -- we just want to say 'In the expression, 'e'.
+ -- which will be adeed by the recursive call in thing_inside
+ -> thing_inside
+ XExpr (ExpandedThingRn o _)
+ -> addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) thing_inside
+ _
+ -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code
+ | otherwise
+ = thing_inside
=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -63,6 +63,7 @@ data ErrCtxt = MkErrCtxt CodeSrcFlag ErrCtxtMsgM
data CodeSrcFlag = VanillaUserSrcCode
| LandmarkUserSrcCode
| ExpansionCodeCtxt SrcCodeOrigin
+ -- INVARIANT: SHOULD NEVER APPEAR IN A ExpansionCodeCtxt in CodeSrcFlag ErrCtxt on stack
--------------------------------------------------------------------------------
-- Error message contexts
=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -196,10 +196,7 @@ setLclEnvErrCtxt :: ErrCtxtStack -> TcLclEnv -> TcLclEnv
setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt })
addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
-addLclEnvErrCtxt ec@(MkErrCtxt (ExpansionCodeCtxt _) _) = setLclEnvSrcCodeOrigin ec
-addLclEnvErrCtxt ec = modifyLclCtxt (\env -> if lclCtxtInGeneratedCode env
- then env -- no op if we are in generated code
- else env { tcl_err_ctxt = ec : (tcl_err_ctxt env) })
+addLclEnvErrCtxt ec = setLclEnvSrcCodeOrigin ec
getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin
getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_err_ctxt . tcl_lcl_ctxt
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/436d9f72a594aefd81f4be102916777…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/436d9f72a594aefd81f4be102916777…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/wasm-dyld-pie] wasm: support running dyld fully client side in browser
by Cheng Shao (＠TerrorJack) 27 Oct '25
by Cheng Shao (＠TerrorJack) 27 Oct '25
27 Oct '25
Cheng Shao pushed to branch wip/wasm-dyld-pie at Glasgow Haskell Compiler / GHC
Commits:
3d7985e3 by Cheng Shao at 2025-10-26T17:53:34+01:00
wasm: support running dyld fully client side in browser
- - - - -
1 changed file:
- utils/jsffi/dyld.mjs
Changes:
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -285,7 +285,7 @@ function originFromServerAddress({ address, family, port }) {
}
// Browser/node portable code stays above this watermark.
-const isNode = Boolean(globalThis?.process?.versions?.node);
+const isNode = Boolean(globalThis?.process?.versions?.node && !globalThis.Deno);
// Too cumbersome to only import at use sites. Too troublesome to
// factor out browser-only/node-only logic into different modules. For
@@ -307,18 +307,22 @@ if (isNode) {
ws = require("ws");
} catch {}
} else {
- wasi = await import(
- "https://cdn.jsdelivr.net/npm/@bjorn3/browser_wasi_shim@0.4.2/dist/index.js"
- );
+ wasi = await import("https://esm.sh/gh/haskell-wasm/browser_wasi_shim");
}
// A subset of dyld logic that can only be run in the host node
// process and has full access to local filesystem
-class DyLDHost {
+export class DyLDHost {
// Deduped absolute paths of directories where we lookup .so files
#rpaths = new Set();
constructor({ out_fd, in_fd }) {
+ // When running a non-iserv shared library with node, the DyLDHost
+ // instance is created without a pair of fds, so skip creation of
+ // readStream/writeStream, they won't be used anyway
+ if (!(typeof out_fd === "number" && typeof in_fd === "number")) {
+ return;
+ }
this.readStream = stream.Readable.toWeb(
fs.createReadStream(undefined, { fd: in_fd })
);
@@ -373,6 +377,75 @@ class DyLDHost {
}
}
+// Runs in the browser and uses the in-memory vfs, doesn't do any RPC
+// calls
+export class DyLDBrowserHost {
+ // Deduped absolute paths of directories where we lookup .so files
+ #rpaths = new Set();
+ // The PreopenDirectory object of the root filesystem
+ rootfs;
+
+ // Given canonicalized absolute file path, returns the File object,
+ // or null if absent
+ #readFile(p) {
+ const { ret, entry } = this.rootfs.dir.get_entry_for_path({
+ parts: p.split("/").filter((tok) => tok !== ""),
+ is_dir: false,
+ });
+ return ret === 0 ? entry : null;
+ }
+
+ constructor({ rootfs }) {
+ this.rootfs = rootfs;
+ }
+
+ close() {}
+
+ // p must be canonicalized absolute path
+ async addLibrarySearchPath(p) {
+ this.#rpaths.add(p);
+ return null;
+ }
+
+ async findSystemLibrary(f) {
+ if (f.startsWith("/")) {
+ if (this.#readFile(f)) {
+ return f;
+ }
+ throw new Error(`findSystemLibrary(${f}): not found in /`);
+ }
+
+ for (const rpath of this.#rpaths) {
+ const r = `${rpath}/${f}`;
+ if (this.#readFile(r)) {
+ return r;
+ }
+ }
+
+ throw new Error(
+ `findSystemLibrary(${f}): not found in ${[...this.#rpaths]}`
+ );
+ }
+
+ async fetchWasm(p) {
+ const entry = this.#readFile(p);
+ const r = new Response(entry.data, {
+ headers: { "Content-Type": "application/wasm" },
+ });
+ // It's only fetched once, take the chance to prune it in vfs to save memory
+ entry.data = new Uint8Array();
+ return r;
+ }
+
+ stdout(msg) {
+ console.info(msg);
+ }
+
+ stderr(msg) {
+ console.warn(msg);
+ }
+}
+
// Fulfill the same functionality as DyLDHost by doing fetch() calls
// to respective RPC endpoints of a host http server. Also manages
// WebSocket connections back to host.
@@ -540,7 +613,7 @@ class DyLDRPCServer {
res.end(
`
import { DyLDRPC, main } from "./fs${dyldPath}";
-const args = ${JSON.stringify({ libdir, ghciSoPath, args })};
+const args = ${JSON.stringify({ libdirs: [libdir], ghciSoPath, args })};
args.rpc = new DyLDRPC({origin: "${origin}", redirectWasiConsole: ${redirectWasiConsole}});
args.rpc.opened.then(() => main(args));
`
@@ -832,6 +905,10 @@ class DyLD {
],
{ debug: false }
);
+
+ if (this.#rpc instanceof DyLDBrowserHost) {
+ this.#wasi.fds[3] = this.#rpc.rootfs;
+ }
}
// Both wasi implementations we use provide
@@ -1218,15 +1295,39 @@ class DyLD {
}
}
-export async function main({ rpc, libdir, ghciSoPath, args }) {
+// The main entry point of dyld that may be run on node/browser, and
+// may run either iserv defaultMain from the ghci library or an
+// alternative entry point from another shared library
+export async function main({
+ rpc, // Handle the side effects of DyLD
+ libdirs, // Initial library search directories
+ ghciSoPath, // Could also be another shared library that's actually not ghci
+ args, // WASI argv without the executable name. +RTS etc will be respected
+ altEntry, // Optional alternative entry point function name
+ altArgs, // Argument array to pass to the alternative entry point function
+}) {
try {
const dyld = new DyLD({
args: ["dyld.so", ...args],
rpc,
});
- await dyld.addLibrarySearchPath(libdir);
+ for (const libdir of libdirs) {
+ await dyld.addLibrarySearchPath(libdir);
+ }
await dyld.loadDLLs(ghciSoPath);
+ // At this point, rts/ghc-internal are loaded, perform wasm shared
+ // library specific RTS startup logic, see Note [JSFFI
+ // initialization]
+ dyld.exportFuncs.__ghc_wasm_jsffi_init();
+
+ // We're not running iserv, just invoke user-specified alternative
+ // entry point and pass the arguments
+ if (altEntry) {
+ return await dyld.exportFuncs[altEntry](...altArgs);
+ }
+
+ // iserv-specific logic follows
const reader = rpc.readStream.getReader();
const writer = rpc.writeStream.getWriter();
@@ -1245,19 +1346,19 @@ export async function main({ rpc, libdir, ghciSoPath, args }) {
writer.write(new Uint8Array(buf));
};
- dyld.exportFuncs.__ghc_wasm_jsffi_init();
- await dyld.exportFuncs.defaultServer(cb_sig, cb_recv, cb_send);
+ return await dyld.exportFuncs.defaultServer(cb_sig, cb_recv, cb_send);
} finally {
rpc.close();
}
}
-export async function nodeMain({ libdir, ghciSoPath, out_fd, in_fd, args }) {
+// node-specific iserv-specific logic
+async function nodeMain({ libdir, ghciSoPath, out_fd, in_fd, args }) {
if (!process.env.GHCI_BROWSER) {
const rpc = new DyLDHost({ out_fd, in_fd });
await main({
rpc,
- libdir,
+ libdirs: [libdir],
ghciSoPath,
args,
});
@@ -1370,15 +1471,11 @@ export async function nodeMain({ libdir, ghciSoPath, out_fd, in_fd, args }) {
);
}
-function isNodeMain() {
- if (!globalThis?.process?.versions?.node) {
- return false;
- }
-
- return import.meta.filename === process.argv[1];
-}
+const isNodeMain = isNode && import.meta.filename === process.argv[1];
-if (isNodeMain()) {
+// node iserv as invoked by
+// GHC.Runtime.Interpreter.Wasm.spawnWasmInterp
+if (isNodeMain) {
const libdir = process.argv[2];
const ghciSoPath = process.argv[3];
const out_fd = Number.parseInt(process.argv[4]),
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d7985e376935e3583370f85a83bbcf…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d7985e376935e3583370f85a83bbcf…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Postscript to fix for #26255
by Marge Bot (＠marge-bot) 27 Oct '25
by Marge Bot (＠marge-bot) 27 Oct '25
27 Oct '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
4f5bf93b by Simon Peyton Jones at 2025-10-25T04:05:34-04:00
Postscript to fix for #26255
This MR has comments only
- - - - -
7cc9732b by IC Rainbow at 2025-10-26T12:42:21-04:00
Add SIMD primops for bitwise logical operations
This adds 128-bit wide and/or/xor instructions for X86 NCG,
with both SSE and AVX encodings.
```
andFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -- andps / vandps
andDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -- andpd / vandpd
andInt8X16# :: Int8X16# -> Int8X16# -> Int8X16# -- pand / vpand
```
The new primops are available on ARM when using LLVM backend.
Tests added:
- simd015 (floats and doubles)
- simd016 (integers)
- simd017 (words)
Fixes #26417
- - - - -
c72d9d4c by sheaf at 2025-10-26T12:42:36-04:00
Add hints for unsolved HasField constraints
This commit adds hints and explanations for unsolved 'HasField'
constraints.
GHC will now provide additional explanations for an unsolved constraint
of the form 'HasField fld_name rec_ty fld_ty'; the details are laid out in
Note [Error messages for unsolved HasField constraints], but briefly:
1. Provide similar name suggestions (e.g. mis-spelled field name)
and import suggestions (record field not in scope).
These result in actionable 'GhcHints', which is helpful to provide
code actions in HLS.
2. Explain why GHC did not solve the constraint, e.g.:
- 'fld_name' is not a string literal (e.g. a type variable)
- 'rec_ty' is a TyCon without any fields, e.g. 'Int' or 'Bool'.
- 'fld_ty' contains existentials variables or foralls.
- The record field is a pattern synonym field (GHC does not generate
HasField instances for those).
- 'HasField' is a custom 'TyCon', not actually the built-in
'HasField' typeclass from 'GHC.Records'.
On the way, we slightly refactor the mechanisms for import suggestions
in GHC.Rename.Unbound. This is to account for the fact that, for
'HasField', we don't care whether the field is imported qualified or
unqualified. 'importSuggestions' was refactored, we now have
'sameQualImportSuggestions' and 'anyQualImportSuggestions'.
Fixes #18776 #22382 #26480
- - - - -
92b38556 by sheaf at 2025-10-26T12:42:36-04:00
Rename PatSyn MatchContext to PatSynCtx to avoid punning
- - - - -
55 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- docs/users_guide/9.16.1-notes.rst
- libraries/base/src/GHC/Base.hs
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-experimental/CHANGELOG.md
- libraries/ghc-prim/changelog.md
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- + testsuite/tests/overloadedrecflds/should_fail/T26480.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480.stderr
- + testsuite/tests/overloadedrecflds/should_fail/T26480_aux1.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480_aux2.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480b.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr
- testsuite/tests/overloadedrecflds/should_fail/all.T
- testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr
- testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
- testsuite/tests/rename/should_fail/T19843h.stderr
- testsuite/tests/simd/should_run/all.T
- + testsuite/tests/simd/should_run/simd015.hs
- + testsuite/tests/simd/should_run/simd015.stdout
- + testsuite/tests/simd/should_run/simd016.hs
- + testsuite/tests/simd/should_run/simd016.stdout
- + testsuite/tests/simd/should_run/simd017.hs
- + testsuite/tests/simd/should_run/simd017.stdout
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ad88789e3cda66f6a59c2643d5042a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ad88789e3cda66f6a59c2643d5042a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/int-index/reexport-ghc-hs-basic
by Vladislav Zavialov (＠int-index) 26 Oct '25
by Vladislav Zavialov (＠int-index) 26 Oct '25
26 Oct '25
Vladislav Zavialov pushed new branch wip/int-index/reexport-ghc-hs-basic at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/reexport-ghc-hs-bas…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26521] ghc-toolchain: refactor, move lastLine to Utils
by Peter Trommler (＠trommler) 26 Oct '25
by Peter Trommler (＠trommler) 26 Oct '25
26 Oct '25
Peter Trommler pushed to branch wip/T26521 at Glasgow Haskell Compiler / GHC
Commits:
cf9d958f by Peter Trommler at 2025-10-26T10:41:44+01:00
ghc-toolchain: refactor, move lastLine to Utils
- - - - -
3 changed files:
- utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
- utils/ghc-toolchain/src/GHC/Toolchain/CheckPower.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
Changes:
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
=====================================
@@ -8,6 +8,7 @@ import System.Process
import GHC.Platform.ArchOS
import GHC.Toolchain.Prelude
+import GHC.Toolchain.Utils (lastLine)
import GHC.Toolchain.Tools.Cc
-- | Awkwardly, ARM triples sometimes contain insufficient information about
@@ -75,10 +76,6 @@ findArmIsa cc = do
"False" -> return False
_ -> throwE $ "unexpected output from test program: " ++ out
-lastLine :: String -> String
-lastLine "" = ""
-lastLine s = last $ lines s
-
-- | Raspbian unfortunately makes some extremely questionable packaging
-- decisions, configuring gcc to compile for ARMv6 despite the fact that the
-- Raspberry Pi 4 is ARMv8. As ARMv8 doesn't support all instructions supported
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/CheckPower.hs
=====================================
@@ -3,6 +3,7 @@ module GHC.Toolchain.CheckPower ( checkPowerAbi ) where
import GHC.Platform.ArchOS
import GHC.Toolchain.Prelude
+import GHC.Toolchain.Utils (lastLine)
import GHC.Toolchain.Tools.Cc
checkPowerAbi :: Cc -> M Arch
@@ -19,8 +20,3 @@ checkPowerAbi cc = do
"ELFv1" -> pure $ ArchPPC_64 ELF_V1
"ELFv2" -> pure $ ArchPPC_64 ELF_V2
_ -> throwE $ "unexpected output from test program: " ++ out
-
--- TODO: move lastLine to a common location
-lastLine :: String -> String
-lastLine "" = ""
-lastLine s = last $ lines s
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
=====================================
@@ -8,6 +8,7 @@ module GHC.Toolchain.Utils
, oneOf
, oneOf'
, isSuccess
+ , lastLine
) where
import Control.Exception
@@ -65,3 +66,6 @@ isSuccess = \case
ExitSuccess -> True
ExitFailure _ -> False
+lastLine :: String -> String
+lastLine "" = ""
+lastLine s = last $ lines s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf9d958f5ed1bebd6f5ff757a6078c9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf9d958f5ed1bebd6f5ff757a6078c9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26349 at Glasgow Haskell Compiler / GHC
Commits:
c97fd3f5 by Simon Peyton Jones at 2025-10-26T00:07:09+01:00
better
- - - - -
3 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Types/Evidence.hs
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -1602,6 +1602,8 @@ ds_hs_wrapper hs_wrap
where
go WpHole k = k $ \e -> e
go (WpSubType w) k = go (optSubTypeHsWrapper w) k
+ -- See (DSST3) in Note [Deep subsumption and WpSubType]
+ -- in GHC.Tc.Types.Evidence
go (WpTyApp ty) k = k $ \e -> App e (Type ty)
go (WpEvLam ev) k = k $ Lam ev
go (WpTyLam tv) k = k $ Lam tv
=====================================
compiler/GHC/Tc/Errors/Hole.hs
=====================================
@@ -823,9 +823,11 @@ tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates =
unfoldWrapper :: HsWrapper -> [Type]
unfoldWrapper = reverse . unfWrp'
- where unfWrp' (WpTyApp ty) = [ty]
- unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2
- unfWrp' _ = []
+ where
+ unfWrp' (WpTyApp ty) = [ty]
+ unfWrp' (WpSubType w) = unfWrp' w
+ unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2
+ unfWrp' _ = []
-- The real work happens here, where we invoke the type checker using
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -138,7 +138,7 @@ maybeSymCo NotSwapped co = co
{- Note [Deep subsumption and WpSubType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When making DeepSubsumption checks, we may end up with hard-to-spot identity wrappers.
-For example (#26255) suppose we have
+For example (#26349) suppose we have
(forall a. Eq a => a->a) -> Int <= (forall a. Eq a => a->a) -> Int
The two types are equal so we should certainly get an identity wrapper. But we'll get
tihs wrapper from `tcSubType`:
@@ -158,11 +158,11 @@ is not sound in general, so we'll end up retaining the lambdas. Two bad results
may not be able to make a decent RULE at all, and will fail with "LHS of rule
is too complicated to desugar (#26255)
-It'd be nicest to solve the problem at source, by never generating those
+It'd be ideal to solve the problem at source, by never generating those
gruesome wrappers in the first place, but we can't do that because
-* The WpTyLam and WpTyApp are not introduced together in `tcSubType`, so we can't
- easily cancel them out. Even if we have
+* The WpTyLam and WpTyApp are introduced independently, not together, in `tcSubType`,
+ so we can't easily cancel them out. For example, even if we have
forall a. t1 <= forall a. t2
there is no guarantee that these are the "same" a. E.g.
forall a b. a -> b -> b <= forall x y. y -> x - >x
@@ -171,17 +171,23 @@ gruesome wrappers in the first place, but we can't do that because
* We have not yet done constraint solving so we don't know what evidence will
end up in those WpLet bindings.
-TL;DR we must generate
-Here's our solution
+TL;DR we must generate the wrapper and then optimise it way if it turns out
+that it is a no-op. Here's our solution
(DSST1) Tag the wrappers generated from a subtype check with WpSubType. In normal
wrappers the binders of a WpTyLam or WpEvLam can scope over the "hole" of the
wrapper -- that is how we introduce type-lambdas and dictionary-lambda into the
terms! But in /subtype/ wrappers, these type/dictionary lambdas only scope over
- the WpTyApp and WpEvApp nodes in the /same/ wrapper. That is w
+ the WpTyApp and WpEvApp nodes in the /same/ wrapper. That is what justifies us
+ eta-reducing the type/dictionarly lambdas.
-(WpSubType wp) means the same as `wp`, but with the added promise that
-the binders in `wp` do not scope over the hole
+ In short, (WpSubType wp) means the same as `wp`, but with the added promise that
+ the binders in `wp` do not scope over the hole
+
+(DSST2) Avoid creating a WpSubType in the common WpHole case, using `mkWpSubType`.
+
+(DSST3) When desugaring, try eta-reduction on the payload of a WpSubType.
+ This is done in `GHC.HsToCore.Binds.dsHsWrapper` by the call to `optSubTypeHsWrapper`.
-}
-- We write wrap :: t1 ~> t2
@@ -190,7 +196,7 @@ data HsWrapper
= WpHole -- The identity coercion
| WpSubType HsWrapper -- (WpSubType wp) Means the same as `wp`
- -- But see Note [WpSubType]
+ -- See Note [Deep subsumption and WpSubType] (DSST1)
| WpCompose HsWrapper HsWrapper
-- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]]
@@ -299,6 +305,7 @@ mkWpFun w_arg w_res t1 t2 = WpFun w_arg w_res t1 t2
-- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
mkWpSubType :: HsWrapper -> HsWrapper
+-- See (DSST2) in Note [Deep subsumption and WpSubType]
mkWpSubType WpHole = WpHole
mkWpSubType (WpCast co) = WpCast co
mkWpSubType w = WpSubType w
@@ -393,7 +400,7 @@ hsWrapDictBinders wrap = go wrap
go (w1 `WpCompose` w2) = go w1 `unionBags` go w2
go (WpFun _ w _ _) = go w
go WpHole = emptyBag
- go (WpSubType {}) = emptyBag -- See Note [WpSubType]
+ go (WpSubType {}) = emptyBag -- See Note [Deep subsumption and WpSubType]
go (WpCast {}) = emptyBag
go (WpEvApp {}) = emptyBag
go (WpTyLam {}) = emptyBag
@@ -420,9 +427,11 @@ collectHsWrapBinders wrap = go wrap []
optSubTypeHsWrapper :: HsWrapper -> HsWrapper
+-- This optimiser is used only on the payload of WpSubType
+-- It finds cases where the entire wrapper is a no-op
+-- See (DSST3) in Note [Deep subsumption and WpSubType]
optSubTypeHsWrapper wrap
- = -- pprTrace "optHsWrapper" (vcat [ text "in:" <+> ppr wrap, text "out:" <+> ppr (opt wrap) ]) $
- opt wrap
+ = opt wrap
where
opt :: HsWrapper -> HsWrapper
opt w = foldr (<.>) WpHole (opt1 w [])
@@ -436,18 +445,17 @@ optSubTypeHsWrapper wrap
opt1 (WpCast co) ws = opt_co co ws
opt1 (WpEvLam ev) ws = opt_ev_lam ev ws
opt1 (WpTyLam tv) ws = opt_ty_lam tv ws
- opt1 (WpLet binds) ws = opt_let binds ws
+ opt1 (WpLet binds) ws = pushWpLet binds ws
opt1 (WpFun w1 w2 sty1 ty2) ws = mk_wp_fun (opt w1) (opt w2) sty1 ty2 ws
opt1 w@(WpTyApp {}) ws = w : ws
opt1 w@(WpEvApp {}) ws = w : ws
- ------------------
- opt_let b@(EvBinds bs) ws | isEmptyBag bs = ws
- | otherwise = WpLet b : ws
- opt_let (TcEvBinds {}) _ = pprPanic "optHsWrapper1" (ppr wrap)
-
-----------------
-- (WpTyLam a <+> WpTyApp a <+> w) = w
+ -- i.e. /\a. <hole> a --> <hole>
+ -- This is only valid if whatever fills the hole does not mention 'a'
+ -- But that's guaranteed in subtype-wrappers;
+ -- see (DSST1) in Note [Deep subsumption and WpSubType]
opt_ty_lam tv (WpTyApp ty : ws)
| Just tv' <- getTyVar_maybe ty
, tv==tv'
@@ -458,15 +466,12 @@ optSubTypeHsWrapper wrap
opt_ty_lam tv (WpCast co : ws)
= opt_co (mkHomoForAllCo tv co) (opt_ty_lam tv ws)
- opt_ty_lam tv (WpLet bs : ws)
- | Just ws' <- pushWpLet bs ws
- = opt_ty_lam tv ws'
-
opt_ty_lam tv ws
= WpTyLam tv : ws
-----------------
-- (WpEvLam ev <+> WpEvAp ev <+> w) = w
+ -- Similar notes to WpTyLam
opt_ev_lam ev (WpEvApp ev_tm : ws)
| EvExpr (Var ev') <- ev_tm
, ev == ev'
@@ -481,9 +486,6 @@ optSubTypeHsWrapper wrap
(mkNomReflCo ManyTy)
(mkRepReflCo (idType ev))
co
- opt_ev_lam ev (WpLet bs : ws)
- | Just ws' <- pushWpLet bs ws
- = opt_ev_lam ev ws'
opt_ev_lam ev ws
= WpEvLam ev : ws
@@ -505,48 +507,64 @@ optSubTypeHsWrapper wrap
where
co_ify co1 co2 = opt_co (mk_wp_fun_co w co1 co2) ws
-pushWpLet :: TcEvBinds -> [HsWrapper] -> Maybe [HsWrapper]
+pushWpLet :: TcEvBinds -> [HsWrapper] -> [HsWrapper]
+-- See if we can transform
+-- WpLet binds <.> w1 <.> .. <.> wn --> w1' <.> .. <.> wn'
+-- by substitution.
+-- We do this just for the narrow case when
+-- - the `binds` are all just v=w, variables only
+-- - the wi are all WpTyApp, WpEvApp, or WpCast
+-- This is just enough to get us the eta-reductions that we seek
pushWpLet tc_ev_binds ws
- | EvBinds binds <- tc_ev_binds
- , Just env <- evBindIdSwizzle binds
- = go env ws
- | otherwise
- = Nothing
+ = case tc_ev_binds of
+ TcEvBinds {} -> pprPanic "pushWpLet" (ppr tc_ev_binds)
+ EvBinds binds
+ | isEmptyBag binds
+ -> ws
+ | Just env <- ev_bind_swizzle binds
+ -> case go env ws of
+ Just ws' -> ws'
+ Nothing -> bale_out
+ | otherwise
+ -> bale_out
where
+ bale_out = WpLet tc_ev_binds : ws
+
go :: IdEnv Id -> [HsWrapper] -> Maybe [HsWrapper]
go env (WpCast co : ws) = do { ws' <- go env ws
; return (WpCast co : ws') }
go env (WpTyApp ty : ws) = do { ws' <- go env ws
; return (WpTyApp ty : ws') }
go env (WpEvApp (EvExpr (Var v)) : ws)
- = do { v' <- swizzleId env v
+ = do { v' <- swizzle_id env v
; ws' <- go env ws
; return (WpEvApp (EvExpr (Var v')) : ws') }
go _ ws = case ws of
[] -> Just []
- (_:_) -> Nothing -- Could not fully eliminate it
+ (_:_) -> Nothing -- Could not fully eliminate the WpLet
-swizzleId :: IdEnv Id -> Id -> Maybe Id
--- Nothing <=> ran out of fuel
--- Shoul
-swizzleId env v = go 100 v
- where
- go :: Int -> EvId -> Maybe EvId
- go fuel v
- | fuel == 0 = Nothing
- | Just v' <- lookupVarEnv env v = go (fuel-1) v'
- | otherwise = Just v
-
-evBindIdSwizzle :: Bag EvBind -> Maybe (IdEnv Id)
-evBindIdSwizzle evbs = foldl' do_one (Just emptyVarEnv) evbs
- where
- do_one :: Maybe (IdEnv Id) -> EvBind -> Maybe (IdEnv Id)
- do_one Nothing _ = Nothing
- do_one (Just swizzle) (EvBind {eb_lhs = bndr, eb_rhs = rhs})
- = case rhs of
- EvExpr (Var v) -> Just (extendVarEnv swizzle bndr v)
- _ -> Nothing
+ swizzle_id :: IdEnv Id -> Id -> Maybe Id
+ -- Nothing <=> ran out of fuel
+ -- This is just belt and braces; we should never build bottom evidence
+ swizzle_id env v = go 100 v
+ where
+ go :: Int -> EvId -> Maybe EvId
+ go fuel v
+ | fuel == 0 = Nothing
+ | Just v' <- lookupVarEnv env v = go (fuel-1) v'
+ | otherwise = Just v
+
+ ev_bind_swizzle :: Bag EvBind -> Maybe (IdEnv Id)
+ -- Succeeds only if the bindings are all var-to-var bindings
+ ev_bind_swizzle evbs = foldl' do_one (Just emptyVarEnv) evbs
+ where
+ do_one :: Maybe (IdEnv Id) -> EvBind -> Maybe (IdEnv Id)
+ do_one Nothing _ = Nothing
+ do_one (Just swizzle) (EvBind {eb_lhs = bndr, eb_rhs = rhs})
+ = case rhs of
+ EvExpr (Var v) -> Just (extendVarEnv swizzle bndr v)
+ _ -> Nothing
{-
************************************************************************
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c97fd3f51c07bca9b2e66545a7bdaac…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c97fd3f51c07bca9b2e66545a7bdaac…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/backports-9.14] 20 commits: testsuite: fix T3586 for non-SSE3 platforms
by Ben Gamari (＠bgamari) 26 Oct '25
by Ben Gamari (＠bgamari) 26 Oct '25
26 Oct '25
Ben Gamari pushed to branch wip/backports-9.14 at Glasgow Haskell Compiler / GHC
Commits:
ffd03d32 by Cheng Shao at 2025-10-25T16:12:45-04:00
testsuite: fix T3586 for non-SSE3 platforms
`T3586.hs` contains `-fvia-C -optc-msse3` which I think is a
best-effort basis to harvest the C compiler's auto vectorization
optimizations via the C backend back when the test was added. The
`-fvia-C` part is now a deprecated no-op because GHC can't fall back
to the C backend on a non-unregisterised build, and `-optc-msse3`
might actually cause the test to fail on non x86/x64 platforms, e.g.
recent builds of wasi-sdk would report `wasm32-wasi-clang: error:
unsupported option '-msse3' for target 'wasm32-unknown-wasi'`.
So this patch cleans up this historical cruft. `-fvia-C` is removed,
and `-optc-msse3` is only passed when cpuid contains `pni` (which
indicates support of SSE3).
(cherry picked from commit 70ee825a516bcf7aac762bfedb4a017d35f8dcf3)
- - - - -
0a01bea2 by Ben Gamari at 2025-10-25T16:12:45-04:00
rts/nonmoving: Fix comment spelling
(cherry picked from commit 14281a22eb27498886def8e5d17797c9ce62f3ad)
- - - - -
836511fe by Ben Gamari at 2025-10-25T16:12:45-04:00
rts/nonmoving: Use atomic operations to update bd->flags
(cherry picked from commit bedd38b01d6b113cb3bd10b5d784c16b32efb5bb)
- - - - -
5a50298b by Ben Gamari at 2025-10-25T16:12:45-04:00
nonmoving: Use get_itbl instead of explicit loads
This is cleaner and also fixes unnecessary (and unsound) use of
`volatile`.
(cherry picked from commit 215d68414020dc4ed0636508c9eecd9f44f62168)
- - - - -
1cfaf40a by Ben Gamari at 2025-10-25T16:12:45-04:00
rts/Scav: Handle WHITEHOLEs in scavenge_one
`scavenge_one`, used to scavenge mutable list entries, may encounter
`WHITEHOLE`s when the non-moving GC is in use via two paths:
1. when an MVAR is being marked concurrently
2. when the object belongs to a chain of selectors being short-cutted.
Fixes #26204.
(cherry picked from commit 2c94aa3aa87c14b1ff5c4355c9a90efedd5d10f4)
- - - - -
d4db67c0 by Ben Gamari at 2025-10-25T16:12:45-04:00
gitlab-ci: Make RELEASE_JOB an input
Rather than an undocumented variable.
(cherry picked from commit f9790ca81deb8b14ff2eabf701aecbcfd6501963)
- - - - -
e3ca15f7 by Julian Ospald at 2025-10-25T16:12:45-04:00
ghc-toolchain: Drop `ld.gold` from merge object command
It's deprecated.
Also see #25716
(cherry picked from commit c58f9a615f05e9d43629f6e846ae22cad2a6163d)
- - - - -
5c820b10 by Ben Gamari at 2025-10-25T16:12:45-04:00
rts/posix: Enforce iteration limit on heap reservation logic
Previously we could loop indefinitely when attempting to get an address
space reservation for our heap. Limit the logic to 8 iterations to
ensure we instead issue a reasonable error message.
Addresses #26151.
(cherry picked from commit ff1650c96c61af02e193854312a9ccd303968e47)
- - - - -
1fb72cf5 by Ben Gamari at 2025-10-25T16:12:45-04:00
rts/posix: Hold on to low reservations when reserving heap
Previously when the OS gave us an address space reservation in low
memory we would immediately release it and try again. However, on some
platforms this meant that we would get the same allocation again in the
next iteration (since mmap's `hint` argument is just that, a hint).
Instead we now hold on to low reservations until we have found a
suitable heap reservation.
Fixes #26151.
(cherry picked from commit 0184455728f841a699648f879fdb29128081fc6b)
- - - - -
10bda05d by Luite Stegeman at 2025-10-25T16:12:45-04:00
rts: Fix lost wakeups in threadPaused for threads blocked on black holes
The lazy blackholing code in threadPaused could overwrite closures
that were already eagerly blackholed, and as such wouldn't have a
marked update frame. If the black hole was overwritten by its
original owner, this would lead to an undetected collision, and
the contents of any existing blocking queue being lost.
This adds a check for eagerly blackholed closures and avoids
overwriting their contents.
Fixes #26324
(cherry picked from commit a1de535f762bc23d4cf23a5b1853591dda12cdc9)
- - - - -
a62540e4 by Luite Stegeman at 2025-10-25T16:12:45-04:00
rts: push the correct update frame in stg_AP_STACK
The frame contains an eager black hole (__stg_EAGER_BLACKHOLE_info) so
we should push an stg_bh_upd_frame_info instead of an stg_upd_frame_info.
(cherry picked from commit b7e21e498d39e0ee764e3237544b4c39ddf98467)
- - - - -
d44e8dbe by sheaf at 2025-10-25T16:12:45-04:00
Improve deep subsumption
This commit improves the DeepSubsumption sub-typing implementation
in GHC.Tc.Utils.Unify.tc_sub_type_deep by being less eager to fall back
to unification.
For example, we now are properly able to prove the subtyping relationship
((∀ a. a->a) -> Int) -> Bool <= β[tau] Bool
for an unfilled metavariable β. In this case (with an AppTy on the right),
we used to fall back to unification. No longer: now, given that the LHS
is a FunTy and that the RHS is a deep rho type (does not need any instantiation),
we try to make the RHS into a FunTy, viz.
β := (->) γ
We can then continue using covariance & contravariance of the function
arrow, which allows us to prove the subtyping relationship, instead of
trying to unify which would cause us to error out with:
Couldn't match expected type ‘β’ with actual type ‘(->) ((∀ a. a -> a) -> Int)
See Note [FunTy vs non-FunTy case in tc_sub_type_deep] in GHC.Tc.Utils.Unify.
The other main improvement in this patch concerns type inference.
The main subsumption logic happens (before & after this patch) in
GHC.Tc.Gen.App.checkResultTy. However, before this patch, all of the
DeepSubsumption logic only kicked in in 'check' mode, not in 'infer' mode.
This patch adds deep instantiation in the 'infer' mode of checkResultTy
when we are doing deep subsumption, which allows us to accept programs
such as:
f :: Int -> (forall a. a->a)
g :: Int -> Bool -> Bool
test1 b =
case b of
True -> f
False -> g
test2 b =
case b of
True -> g
False -> f
See Note [Deeply instantiate in checkResultTy when inferring].
Finally, we add representation-polymorphism checks to ensure that the
lambda abstractions we introduce when doing subsumption obey the
representation polymorphism invariants of Note [Representation polymorphism invariants]
in GHC.Core. See Note [FunTy vs FunTy case in tc_sub_type_deep].
This is accompanied by a courtesy change to `(<.>) :: HsWrapper -> HsWrapper -> HsWrapper`,
adding the equation:
WpCast c1 <.> WpCast c2 = WpCast (c1 `mkTransCo` c2)
This is useful because mkWpFun does not introduce an eta-expansion when
both of the argument & result wrappers are casts; so this change allows
us to avoid introducing lambda abstractions when casts suffice.
Fixes #26225
(cherry picked from commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1)
- - - - -
9b42551e by Simon Peyton Jones at 2025-10-25T16:12:46-04:00
Fix deep subsumption again
This commit fixed #26255:
commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1
Author: sheaf <sam.derbyshire(a)gmail.com>
Date: Mon Aug 11 15:50:47 2025 +0200
Improve deep subsumption
This commit improves the DeepSubsumption sub-typing implementation
in GHC.Tc.Utils.Unify.tc_sub_type_deep by being less eager to fall back
to unification.
But alas it still wasn't quite right for view patterns: #26331
This MR does a generalisation to fix it. A bit of a sledgehammer to crack
a nut, but nice.
* Add a field `ir_inst :: InferInstFlag` to `InferResult`, where
```
data InferInstFlag = IIF_Sigma | IIF_ShallowRho | IIF_DeepRho
```
* The flag says exactly how much `fillInferResult` should instantiate
before filling the hole.
* We can also use this to replace the previous very ad-hoc `tcInferSigma`
that was used to implement GHCi's `:type` command.
(cherry picked from commit 716274a5b6c35d963091f563c98d07e72ee4d755)
- - - - -
6c0409bc by sheaf at 2025-10-25T16:12:46-04:00
Use tcMkScaledFunTys in matchExpectedFunTys
We should use tcMkScaledFunTys rather than mkScaledFunTys in
GHC.Tc.Utils.Unify.matchExpectedFunTys, as the latter crashes
when the kind of the result type is a bare metavariable.
We know the result is always Type-like, so we don't need scaledFunTys
to try to rediscover that from the kind.
Fixes #26277
(cherry picked from commit 624afa4a65caa8ec23f85e70574dfb606f90c173)
- - - - -
1e5a7d25 by sheaf at 2025-10-25T16:12:46-04:00
Deep subsumption: unify mults without tcEqMult
As seen in #26332, we may well end up with a non-reflexive multiplicity
coercion when doing deep subsumption. We should do the same thing that
we do without deep subsumption: unify the multiplicities normally,
without requiring that the coercion is reflexive (which is what
'tcEqMult' was doing).
Fixes #26332
(cherry picked from commit dc79593d4606e5cea93e742a9f2def53705bc773)
- - - - -
7ddb64c2 by Teo Camarasu at 2025-10-25T16:12:46-04:00
ghc-internal: invert dependency of GHC.Internal.TH.Syntax on Data.Data
This means that Data.Data no longer blocks building TH.Syntax, which
allows greater parallelism in our builds.
We move the Data.Data.Data instances to Data.Data. Quasi depends on
Data.Data for one of its methods, so,
we split the Quasi/Q, etc definition out of GHC.Internal.TH.Syntax
into its own module. This has the added benefit of splitting up this
quite large module.
Previously TH.Syntax was a bottleneck when compiling ghc-internal. Now
it is less of a bottle-neck and is also slightly quicker to
compile (since it no longer contains these instances) at the cost of
making Data.Data slightly more expensive to compile.
TH.Lift which depends on TH.Syntax can also compile quicker and no
longer blocks ghc-internal finishing to compile.
Resolves #26217
-------------------------
Metric Decrease:
MultiLayerModulesTH_OneShot
T13253
T21839c
T24471
Metric Increase:
T12227
-------------------------
- - - - -
6477204c by Teo Camarasu at 2025-10-25T16:12:46-04:00
Add submodules for template-haskell-lift and template-haskell-quasiquoter
These two new boot libraries expose stable subsets of the
template-haskell interface.
This is an implemenation of the GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/696
Work towards #25262
(cherry picked from commit 4be32153febff94f9c89f7f74971da3721d19c87)
- - - - -
0ee3398e by Ben Gamari at 2025-10-25T16:12:46-04:00
testsuite: Accept new template-haskell-exports output
- - - - -
4686a8b2 by Ben Gamari at 2025-10-25T16:12:46-04:00
testsuite: Accept new base-exports output
- - - - -
387872bd by Ben Gamari at 2025-10-25T16:12:46-04:00
template-haskell: Accept T15321
- - - - -
92 changed files:
- .gitlab-ci.yml
- .gitmodules
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Builtin/PrimOps/Ids.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Types/TH.hs
- compiler/GHC/Tc/Utils/Concrete.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Types/Id/Make.hs
- hadrian/src/Packages.hs
- hadrian/src/Settings/Default.hs
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/Data/Fixed.hs
- + libraries/ghc-boot-th/GHC/Boot/TH/Monad.hs
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- + libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- + libraries/template-haskell-lift
- + libraries/template-haskell-quasiquoter
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- rts/Apply.cmm
- rts/ThreadPaused.c
- rts/include/rts/storage/Block.h
- rts/posix/OSMem.c
- rts/sm/NonMoving.c
- rts/sm/NonMovingMark.c
- rts/sm/Scav.c
- testsuite/driver/cpu_features.py
- testsuite/tests/corelint/LintEtaExpand.stderr
- testsuite/tests/deriving/should_compile/T14682.stderr
- testsuite/tests/deriving/should_compile/drv-empty-data.stderr
- testsuite/tests/indexed-types/should_fail/T5439.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- + testsuite/tests/linear/should_compile/T26332.hs
- testsuite/tests/linear/should_compile/all.T
- testsuite/tests/partial-sigs/should_compile/T10403.stderr
- testsuite/tests/partial-sigs/should_fail/T10615.stderr
- + testsuite/tests/patsyn/should_compile/T26331.hs
- + testsuite/tests/patsyn/should_compile/T26331a.hs
- testsuite/tests/patsyn/should_compile/all.T
- testsuite/tests/perf/should_run/T3586.hs
- testsuite/tests/perf/should_run/all.T
- testsuite/tests/plugins/plugins10.stdout
- + testsuite/tests/rep-poly/NoEtaRequired.hs
- testsuite/tests/rep-poly/T21906.stderr
- testsuite/tests/rep-poly/all.T
- testsuite/tests/splice-imports/SI29.stderr
- testsuite/tests/th/T11452.stderr
- testsuite/tests/th/T15321.stderr
- testsuite/tests/th/T7276.stderr
- testsuite/tests/th/TH_NestedSplicesFail3.stderr
- testsuite/tests/th/TH_NestedSplicesFail4.stderr
- + testsuite/tests/typecheck/should_compile/T26225.hs
- + testsuite/tests/typecheck/should_compile/T26225b.hs
- + testsuite/tests/typecheck/should_compile/T26277.hs
- testsuite/tests/typecheck/should_compile/all.T
- − testsuite/tests/typecheck/should_fail/T12563.stderr
- testsuite/tests/typecheck/should_fail/T14618.stderr
- testsuite/tests/typecheck/should_fail/T6022.stderr
- testsuite/tests/typecheck/should_fail/T8883.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail140.stderr
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e86b75973070d173cdb4a7dc54a58b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e86b75973070d173cdb4a7dc54a58b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0