Simon Peyton Jones pushed to branch wip/T26349 at Glasgow Haskell Compiler / GHC
Commits:
2004c1aa by Simon Peyton Jones at 2025-10-26T23:43:34+00:00
More
- - - - -
5 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Unify.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -809,7 +809,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
= do { let herald = case fun_ctxt of
VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
_ -> ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
- ; (wrap, arg_ty, res_ty) <-
+ ; (fun_co, arg_ty, res_ty) <-
-- NB: matchActualFunTy does the rep-poly check.
-- For example, suppose we have f :: forall r (a::TYPE r). a -> Int
-- In an application (f x), we need 'x' to have a fixed runtime
@@ -820,7 +820,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
(n_val_args, fun_sigma) fun_ty
; arg' <- quickLookArg do_ql ctxt arg arg_ty
- ; let acc' = arg' : addArgWrap wrap acc
+ ; let acc' = arg' : addArgWrap (mkWpCastN fun_co) acc
; go (pos+1) acc' res_ty rest_args }
new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType)
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -765,13 +765,13 @@ tcInferOverLit lit@(OverLit { ol_val = val
thing = NameThing from_name
mb_thing = Just thing
herald = ExpectedFunTyArg thing (HsLit noExtField hs_lit)
- ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty
+ ; (co2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty
; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
-- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast
; let lit_expr = L (l2l loc) $ mkHsWrapCo co $
HsLit noExtField hs_lit
- from_expr = mkHsWrap (wrap2 <.> wrap1) $
+ from_expr = mkHsWrap (mkWpCastN co2 <.> wrap1) $
mkHsVar (L loc from_id)
witness = HsApp noExtField (L (l2l loc) from_expr) lit_expr
lit' = OverLit { ol_val = val
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -701,7 +701,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-- Expression must be a function
; let herald = ExpectedFunTyViewPat $ unLoc expr
- ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)
+ ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma)
<- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
-- See Note [View patterns and polymorphism]
-- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
@@ -722,7 +722,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-- NB: pat_ty comes from matchActualFunTy, so it has a
-- fixed RuntimeRep, as needed to call mkWpFun.
- expr_wrap = expr_wrap2' <.> expr_wrap1
+ expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1
; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -290,19 +290,24 @@ mkWpFun :: HsWrapper -> HsWrapper
-> TcType -- ^ Either "from" type or "to" type of the second wrapper
-- (used only when the second wrapper is the identity)
-> HsWrapper
-mkWpFun WpHole WpHole _ _ = WpHole
-mkWpFun w_arg w_res t1 t2 = WpFun w_arg w_res t1 t2
- -- In this case, we will desugar to a lambda
- --
- -- \x. w_res[ e w_arg[x] ]
- --
- -- To satisfy Note [Representation polymorphism invariants] in GHC.Core,
- -- it must be the case that both the lambda bound variable x and the function
- -- argument w_arg[x] have a fixed runtime representation, i.e. that both the
- -- "from" and "to" types of the first wrapper "w_arg" have a fixed runtime representation.
- --
- -- Unfortunately, we can't check this with an assertion here, because of
- -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
+mkWpFun w1 w2 st1@(Scaled m1 t1) t2
+ = case (w1,w2) of
+ (WpHole, WpHole) -> WpHole
+ (WpHole, WpCast co2) -> WpCast (mk_wp_fun_co m1 (mkRepReflCo t1) co2)
+ (WpCast co1, WpHole) -> WpCast (mk_wp_fun_co m1 (mkSymCo co1) (mkRepReflCo t2))
+ (WpCast co1, WpCast co2) -> WpCast (mk_wp_fun_co m1 (mkSymCo co1) co2)
+ (_, _) -> WpFun w1 w2 st1 t2
+ -- In the WpFun case, we will desugar to a lambda
+ --
+ -- \x. w_res[ e w_arg[x] ]
+ --
+ -- To satisfy Note [Representation polymorphism invariants] in GHC.Core,
+ -- it must be the case that both the lambda bound variable x and the function
+ -- argument w_arg[x] have a fixed runtime representation, i.e. that both the
+ -- "from" and "to" types of the first wrapper "w_arg" have a fixed runtime representation.
+ --
+ -- Unfortunately, we can't check this with an assertion here, because of
+ -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
mkWpSubType :: HsWrapper -> HsWrapper
-- See (DSST2) in Note [Deep subsumption and WpSubType]
@@ -446,7 +451,7 @@ optSubTypeHsWrapper wrap
opt1 (WpEvLam ev) ws = opt_ev_lam ev ws
opt1 (WpTyLam tv) ws = opt_ty_lam tv 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 (WpFun w1 w2 sty1 ty2) ws = opt_fun w1 w2 sty1 ty2 ws
opt1 w@(WpTyApp {}) ws = w : ws
opt1 w@(WpEvApp {}) ws = w : ws
@@ -459,6 +464,7 @@ optSubTypeHsWrapper wrap
opt_ty_lam tv (WpTyApp ty : ws)
| Just tv' <- getTyVar_maybe ty
, tv==tv'
+ , all (not_in tv) ws
= ws
-- (WpTyLam a <+> WpCastCo co <+> w)
@@ -475,6 +481,7 @@ optSubTypeHsWrapper wrap
opt_ev_lam ev (WpEvApp ev_tm : ws)
| EvExpr (Var ev') <- ev_tm
, ev == ev'
+ , all (not_in ev) ws
= ws
-- (WpEvLam ev <.> WpCast co <.> w)
@@ -497,15 +504,28 @@ optSubTypeHsWrapper wrap
| otherwise = WpCast co : ws
------------------
- mk_wp_fun w1 w2 sty1@(Scaled w t1) ty2 ws
- = case (w1, w2) of
- (WpHole, WpHole) -> ws
- (WpHole, WpCast co2) -> co_ify (mkRepReflCo t1) co2
- (WpCast co1, WpHole) -> co_ify (mkSymCo co1) (mkRepReflCo ty2)
- (WpCast co1, WpCast co2) -> co_ify (mkSymCo co1) co2
- (w1', w2') -> WpFun w1' w2' sty1 ty2 : ws
- where
- co_ify co1 co2 = opt_co (mk_wp_fun_co w co1 co2) ws
+ opt_fun w1 w2 sty1 ty2 ws
+ = case mkWpFun (opt w1) (opt w2) sty1 ty2 of
+ WpHole -> ws
+ WpCast co -> opt_co co ws
+ w -> w : ws
+
+ ------------------
+ -- Tiresome check that the lambda-bound type/evidence variable that we
+ -- want to eta-reduce isn't free in the rest of the wrapper
+ not_in :: TyVar -> HsWrapper -> Bool
+ not_in _ WpHole = True
+ not_in v (WpCast co) = not (anyFreeVarsOfCo (== v) co)
+ not_in v (WpTyApp ty) = not (anyFreeVarsOfType (== v) ty)
+ not_in v (WpFun w1 w2 _ _) = not_in v w1 && not_in v w2
+ not_in v (WpSubType w) = not_in v w
+ not_in v (WpCompose w1 w2) = not_in v w1 && not_in v w2
+ not_in v (WpEvApp (EvExpr e)) = not (v `elemVarSet` exprFreeVars e)
+ not_in _ (WpEvApp (EvTypeable {})) = False -- Giving up; conservative
+ not_in _ (WpEvApp (EvFun {})) = False -- Giving up; conservative
+ not_in _ (WpTyLam {}) = False -- Give up; conservative
+ not_in _ (WpEvLam {}) = False -- Ditto
+ not_in _ (WpLet {}) = False -- Ditto
pushWpLet :: TcEvBinds -> [HsWrapper] -> [HsWrapper]
-- See if we can transform
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -147,7 +147,7 @@ matchActualFunTy
-- (Both are used only for error messages)
-> TcRhoType
-- ^ Type to analyse: a TcRhoType
- -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)
+ -> TcM (TcCoercion, Scaled TcSigmaTypeFRR, TcSigmaType)
-- This function takes in a type to analyse (a RhoType) and returns
-- an argument type and a result type (splitting apart a function arrow).
-- The returned argument type is a SigmaType with a fixed RuntimeRep;
@@ -171,13 +171,13 @@ matchActualFunTy herald mb_thing err_info fun_ty
-- hide the forall inside a meta-variable
go :: TcRhoType -- The type we're processing, perhaps after
-- expanding type synonyms
- -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)
+ -> TcM (TcCoercion, Scaled TcSigmaTypeFRR, TcSigmaType)
go ty | Just ty' <- coreView ty = go ty'
go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })
= assert (isVisibleFunArg af) $
do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty
- ; return (idHsWrapper, Scaled w arg_ty, res_ty) }
+ ; return (mkNomReflCo fun_ty, Scaled w arg_ty, res_ty) }
go ty@(TyVarTy tv)
| isMetaTyVar tv
@@ -209,7 +209,7 @@ matchActualFunTy herald mb_thing err_info fun_ty
; res_ty <- newOpenFlexiTyVarTy
; let unif_fun_ty = mkScaledFunTys [arg_ty] res_ty
; co <- unifyType mb_thing fun_ty unif_fun_ty
- ; return (mkWpCastN co, arg_ty, res_ty) }
+ ; return (co, arg_ty, res_ty) }
------------
mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)
@@ -248,8 +248,8 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected
-> Arity
-> TcSigmaType
-> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType)
--- If matchActualFunTys n ty = (wrap, [t1,..,tn], res_ty)
--- then wrap : ty ~> (t1 -> ... -> tn -> res_ty)
+-- If matchActualFunTys n fun_ty = (wrap, [t1,..,tn], res_ty)
+-- then wrap : fun_ty ~> (t1 -> ... -> tn -> res_ty)
-- and res_ty is a RhoType
-- NB: the returned type is top-instantiated; it's a RhoType
matchActualFunTys herald ct_orig n_val_args_wanted top_ty
@@ -264,15 +264,13 @@ matchActualFunTys herald ct_orig n_val_args_wanted top_ty
go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
go n so_far fun_ty
- = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTy
- herald Nothing
- (n_val_args_wanted, top_ty)
- fun_ty
- ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
+ = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing
+ (n_val_args_wanted, top_ty) fun_ty
+ ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
-- NB: arg_ty1 comes from matchActualFunTy, so it has
- -- a syntactically fixed RuntimeRep as needed to call mkWpFun.
- ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }
+ -- a syntactically fixed RuntimeRep
+ ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) }
{-
************************************************************************
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2004c1aab855043dd009f10df32f0fc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2004c1aab855043dd009f10df32f0fc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23162-spj] 16 commits: Fix stack decoding when using profiled runtime
by Simon Peyton Jones (＠simonpj) 26 Oct '25
by Simon Peyton Jones (＠simonpj) 26 Oct '25
26 Oct '25
Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
Commits:
38d65187 by Matthew Pickering at 2025-10-21T13:12:20+01:00
Fix stack decoding when using profiled runtime
There are three fixes in this commit.
* We need to replicate the `InfoTable` and `InfoTableProf`
approach for the other stack constants (see the new Stack.ConstantsProf
file).
* Then we need to appropiately import the profiled or non-profiled
versions.
* Finally, there was an incorrect addition in `stackFrameSize`. We need
to cast after performing addition on words.
Fixes #26507
- - - - -
17231bfb by fendor at 2025-10-21T13:12:20+01:00
Add regression test for #26507
- - - - -
4f5bf93b by Simon Peyton Jones at 2025-10-25T04:05:34-04:00
Postscript to fix for #26255
This MR has comments only
- - - - -
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
- - - - -
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
- - - - -
19f27e96 by Richard Eisenberg at 2025-10-26T22:34:44+00:00
Refactor fundep solving
This commit is a large-scale refactor of the increasingly-messy code that
handles functional dependencies. It has virtually no effect on what compiles
but improves error messages a bit. And it does the groundwork for #23162.
The big picture is described in
Note [Overview of functional dependencies in type inference]
in GHC.Tc.Solver.FunDeps
* New module GHC.Tc.Solver.FunDeps contains all the fundep-handling
code for the constraint solver.
* Fundep-equalities are solved in a nested scope; they may generate
unifications but otherwise have no other effect.
See GHC.Tc.Solver.FunDeps.solveFunDeps
The nested needs to start from the Givens in the inert set, but
not the Wanteds; hence a new function `resetInertCans`, used in
`nestFunDepsTcS`.
* That in turn means that fundep equalities never show up in error
messages, so the complicated FunDepOrigin tracking can all disappear.
* We need to be careful about tracking unifications, so we kick out
constraints from the inert set after doing unifications. Unification
tracking has been majorly reformed: see Note [WhatUnifications] in
GHC.Tc.Utils.Unify.
A good consequence is that the hard-to-grok `resetUnificationFlag`
has been replaced with a simpler use of
`reportCoarseGrainUnifications`
Smaller things:
* Rename `FunDepEqn` to `FunDepEqns` since it contains multiple
type equalities.
Some compile time improvement
Metrics: compile_time/bytes allocated
Baseline
Test value New value Change
---------------------- --------------------------------------
T5030(normal) 173,839,232 148,115,248 -14.8% GOOD
hard_hole_fits(normal) 286,768,048 284,015,416 -1.0%
geo. mean -0.2%
minimum -14.8%
maximum +0.3%
Metric Decrease:
T5030
- - - - -
0a5edc57 by Simon Peyton Jones at 2025-10-26T22:34:53+00:00
QuickLook's tcInstFun should make instantiation variables directly
tcInstFun must make "instantiation variables", not regular
unification variables, when instantiating function types. That was
previously implemented by a hack: set the /ambient/ level to QLInstTyVar.
But the hack finally bit me, when I was refactoring WhatUnifications.
And it was always wrong: see the now-expunged (TCAPP2) note.
This commit does it right, by making tcInstFun call its own
instantiation functions. That entails a small bit of duplication,
but the result is much, much cleaner.
- - - - -
91ecdff2 by Simon Peyton Jones at 2025-10-26T22:34:53+00:00
Build implication for constraints from (static e)
This commit addresses #26466, by buiding an implication for the
constraints arising from a (static e) form. The implication has
a special ic_info field of StaticFormSkol, which tells the constraint
solver to use an empty set of Givens.
See (SF3) in Note [Grand plan for static forms]
in GHC.Iface.Tidy.StaticPtrTable
This commit also reinstates an `assert` in GHC.Tc.Solver.Equality.
The test `StaticPtrTypeFamily` was failing with an assertion failure,
but it now works.
- - - - -
b6c3e03d by Simon Peyton Jones at 2025-10-26T22:34:53+00:00
Comments about defaulting representation equalities
- - - - -
7092e1cd by Simon Peyton Jones at 2025-10-26T22:34:53+00:00
Improve tracking of rewriter-sets
This refactor substantially improves the treatment of so-called
"rewriter-sets" in the constraint solver.
The story is described in the rewritten
Note [Wanteds rewrite Wanteds: rewriter-sets]
in GHC.Tc.Types.Constraint
Some highlights
* Trace the free coercion holes of a filled CoercionHole,
in CoercionPlusHoles. See Note [Coercion holes] (COH5)
This avoids taking having to take the free coercion variables
of a coercion when zonking a rewrriter-set
* Many knock on changes
* Make fillCoercionHole take CoercionPlusHoles as its argument
rather than to separate arguments.
* Similarly setEqIfWanted, setWantedE, wrapUnifierAndEmit.
* Be more careful about passing the correct CoHoleSet to
`rewriteEqEvidence` and friends
* Make kickOurAfterFillingCoercionHole more clever. See
new Note [Kick out after filling a coercion hole]
Smaller matters
* Rename RewriterSet to CoHoleSet
* Add special-case helper `rewriteEqEvidenceSwapOnly`
- - - - -
47d5baaa by Simon Peyton Jones at 2025-10-26T22:34:53+00:00
Tidy up constraint solving for foralls
* In `can_eq_nc_forall` make sure to track Givens that are used
in the nested solve step.
* Tiny missing-swap bug-fix in `lookup_eq_in_qcis`
* Fix some leftover mess from
commit 14123ee646f2b9738a917b7cec30f9d3941c13de
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Wed Aug 20 00:35:48 2025 +0100
Solve forall-constraints via an implication, again
Specifically, trySolveImplication is now dead.
- - - - -
d1781171 by Simon Peyton Jones at 2025-10-26T22:34:53+00:00
Do not treat CoercionHoles as free variables in coercions
This fixes a long-standing wart in the free-variable finder;
now CoercionHoles are no longer treated as a "free variable"
of a coercion.
I got big and unexpected performance regressions when making
this change. Turned out that CallArity didn't discover that
the free variable finder could be eta-expanded, which gave very
poor code.
So I re-used Note [The one-shot state monad trick] for Endo,
resulting in GHC.Utils.EndoOS. Very simple, big win.
- - - - -
e23d6b31 by Simon Peyton Jones at 2025-10-26T22:34:53+00:00
Update debug-tracing in CallArity
No effect on behaviour, and commented out anyway
- - - - -
24c958bb by Simon Peyton Jones at 2025-10-26T22:34:53+00:00
Comments only -- remove dangling Note references
- - - - -
b24482e2 by Simon Peyton Jones at 2025-10-26T22:34:53+00:00
Accept error message wibbles
- - - - -
152 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/Core/Opt/CallArity.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Eval.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/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Instance/FunDeps.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- + compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Irred.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Solver/Solve.hs-boot
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/Unique/DSM.hs
- + compiler/GHC/Utils/EndoOS.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/ghc.cabal.in
- 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-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- + libraries/ghc-internal/tests/backtraces/T26507.hs
- + libraries/ghc-internal/tests/backtraces/T26507.stderr
- libraries/ghc-internal/tests/backtraces/all.T
- libraries/ghc-internal/tests/stack-annotation/all.T
- libraries/ghc-prim/changelog.md
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/default/default-fail05.stderr
- testsuite/tests/dependent/should_fail/T13135_simple.stderr
- testsuite/tests/deriving/should_fail/T3621.stderr
- testsuite/tests/indexed-types/should_fail/T14369.stderr
- testsuite/tests/indexed-types/should_fail/T1897b.stderr
- 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/linters/notes.stdout
- + 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/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
- testsuite/tests/parser/should_fail/T20654a.stderr
- testsuite/tests/partial-sigs/should_fail/T14584a.stderr
- testsuite/tests/polykinds/T6068.stdout
- testsuite/tests/quantified-constraints/T15359.hs
- testsuite/tests/rename/should_fail/T19843h.stderr
- testsuite/tests/rep-poly/RepPolyNPlusK.stderr
- testsuite/tests/rep-poly/RepPolyRightSection.stderr
- testsuite/tests/rep-poly/T13233.stderr
- testsuite/tests/rep-poly/T19709b.stderr
- testsuite/tests/rep-poly/T23903.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
- testsuite/tests/typecheck/no_skolem_info/T13499.stderr
- testsuite/tests/typecheck/should_compile/T13651.hs
- − testsuite/tests/typecheck/should_compile/T13651.stderr
- + testsuite/tests/typecheck/should_compile/T14745.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr
- testsuite/tests/typecheck/should_compile/tc126.hs
- testsuite/tests/typecheck/should_fail/AmbigFDs.hs
- − testsuite/tests/typecheck/should_fail/AmbigFDs.stderr
- testsuite/tests/typecheck/should_fail/FD3.stderr
- testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr
- testsuite/tests/typecheck/should_fail/T13506.stderr
- testsuite/tests/typecheck/should_fail/T16512a.stderr
- testsuite/tests/typecheck/should_fail/T18851b.hs
- − testsuite/tests/typecheck/should_fail/T18851b.stderr
- testsuite/tests/typecheck/should_fail/T18851c.hs
- − testsuite/tests/typecheck/should_fail/T18851c.stderr
- testsuite/tests/typecheck/should_fail/T19415.stderr
- testsuite/tests/typecheck/should_fail/T19415b.stderr
- testsuite/tests/typecheck/should_fail/T22684.stderr
- + testsuite/tests/typecheck/should_fail/T23162a.hs
- + testsuite/tests/typecheck/should_fail/T23162a.stderr
- testsuite/tests/typecheck/should_fail/T25325.stderr
- testsuite/tests/typecheck/should_fail/T5246.stderr
- testsuite/tests/typecheck/should_fail/T5978.stderr
- testsuite/tests/typecheck/should_fail/T7368a.stderr
- testsuite/tests/typecheck/should_fail/T7696.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail122.stderr
- testsuite/tests/typecheck/should_fail/tcfail143.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bea7fbdfe64e5d96f29813bc3ef927…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bea7fbdfe64e5d96f29813bc3ef927…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: Add hints for unsolved HasField constraints
by Marge Bot (＠marge-bot) 26 Oct '25
by Marge Bot (＠marge-bot) 26 Oct '25
26 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) 26 Oct '25
by Marge Bot (＠marge-bot) 26 Oct '25
26 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) 26 Oct '25
by Vladislav Zavialov (＠int-index) 26 Oct '25
26 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) 26 Oct '25
by Cheng Shao (＠TerrorJack) 26 Oct '25
26 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) 26 Oct '25
by Marge Bot (＠marge-bot) 26 Oct '25
26 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