[Git][ghc/ghc][wip/T21623] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Aug 29 16:49:36 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
9e2f92c1 by Simon Peyton Jones at 2022-08-29T16:10:19+01:00
Wibbles
- - - - -
15 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/RoughMap.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
- testsuite/tests/pmcheck/should_compile/T11195.hs
- testsuite/tests/roles/should_compile/Roles3.stderr
- testsuite/tests/tcplugins/ArgsPlugin.hs
- testsuite/tests/tcplugins/EmitWantedPlugin.hs
- testsuite/tests/tcplugins/RewritePlugin.hs
- testsuite/tests/tcplugins/TyFamPlugin.hs
- testsuite/tests/typecheck/should_compile/T18406b.stderr
- testsuite/tests/typecheck/should_compile/T18529.stderr
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -1491,9 +1491,8 @@ constraintKindTyConName :: Name
constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint")
constraintKindTyConKey constraintKindTyCon
-typeToTypeKind, constraintKind :: Kind
+constraintKind :: Kind
constraintKind = mkTyConTy constraintKindTyCon
-typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind
----------------------
-- type Type = TYPE LiftedRep
@@ -1507,8 +1506,9 @@ liftedTypeKindTyConName :: Name
liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")
liftedTypeKindTyConKey liftedTypeKindTyCon
-liftedTypeKind :: Type
+liftedTypeKind, typeToTypeKind :: Type
liftedTypeKind = mkTyConTy liftedTypeKindTyCon
+typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind
----------------------
-- type UnliftedType = TYPE ('BoxedRep 'Unlifted)
=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -367,7 +367,7 @@ type FamInstEnvs = (FamInstEnv, FamInstEnv)
data FamInstEnv
= FamIE !Int -- The number of instances, used to choose the smaller environment
- -- when checking type family consistnecy of home modules.
+ -- when checking type family consistency of home modules.
!(RoughMap FamInst)
-- See Note [FamInstEnv]
-- See Note [FamInstEnv determinism]
=====================================
compiler/GHC/Core/RoughMap.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Core.Type
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Builtin.Types.Prim( cONSTRAINTTyConName, tYPETyConName )
import Control.Monad (join)
import Data.Data (Data)
@@ -275,11 +276,23 @@ typeToRoughMatchTc :: Type -> RoughMatchTc
typeToRoughMatchTc ty
| Just (ty', _) <- splitCastTy_maybe ty = typeToRoughMatchTc ty'
| Just (tc,_) <- splitTyConApp_maybe ty
- , not (isTypeFamilyTyCon tc) = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc)
- RM_KnownTc $! tyConName tc
+ , not (isTypeFamilyTyCon tc) = RM_KnownTc $! roughMatchTyConName tc
-- See Note [Rough matching in class and family instances]
| otherwise = RM_WildCard
+roughMatchTyConName :: TyCon -> Name
+roughMatchTyConName tc
+ | tc_name == cONSTRAINTTyConName
+ = tYPETyConName -- TYPE and CONSTRAINT are not apart, so they must use
+ -- the same rough-map key. We arbitrarily use TYPE.
+ -- See Note [Type and Constraint are not apart]
+ -- in GHC.Builtin.Types.Prim
+ | otherwise
+ = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) tc_name
+ where
+ tc_name = tyConName tc
+
+
-- | Trie of @[RoughMatchTc]@
--
-- *Examples*
@@ -333,6 +346,7 @@ lookupRM' (RML_KnownTc tc : tcs) rm =
(m, u) = maybe (emptyBag, []) (lookupRM' tcs) (lookupDNameEnv (rm_known rm) tc)
in (rm_empty rm `unionBags` common_m `unionBags` m
, bagToList (rm_empty rm) ++ common_u ++ u)
+
-- A RML_NoKnownTC does **not** match any KnownTC but can unify
lookupRM' (RML_NoKnownTc : tcs) rm =
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -244,10 +244,17 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
; let
- -- Drop the foralls before inspecting the
- -- structure of the foreign type.
- (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty)
- id = mkLocalId nm ManyTy sig_ty
+ -- Drop the foralls before inspecting the
+ -- structure of the foreign type.
+ -- Use splitFunTys, which splits (=>) as well as (->)
+ -- so that for foreign import foo :: Eq a => a -> blah
+ -- we get "unacceptable argument Eq a" rather than
+ -- "unacceptable result Eq a => a -> blah"
+ -- Not a big deal. We could make a better error message specially
+ -- for overloaded functions, but doesn't seem worth it
+ (arg_tys, res_ty) = splitFunTys (dropForAlls norm_sig_ty)
+
+ id = mkLocalId nm ManyTy sig_ty
-- Use a LocalId to obey the invariant that locally-defined
-- things are LocalIds. However, it does not need zonking,
-- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it).
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -61,6 +61,7 @@ GHC.Core.SimpleOpt
GHC.Core.Stats
GHC.Core.Subst
GHC.Core.Tidy
+GHC.Core.TyCo.Compare
GHC.Core.TyCo.FVs
GHC.Core.TyCo.Ppr
GHC.Core.TyCo.Rep
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -61,6 +61,7 @@ GHC.Core.SimpleOpt
GHC.Core.Stats
GHC.Core.Subst
GHC.Core.Tidy
+GHC.Core.TyCo.Compare
GHC.Core.TyCo.FVs
GHC.Core.TyCo.Ppr
GHC.Core.TyCo.Rep
=====================================
testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
=====================================
@@ -12,7 +12,8 @@ import Data.List
import GHC.Tc.Types
import qualified Data.Map as M
import Control.Monad (liftM2)
-import GHC.Tc.Utils.TcType
+import GHC.Tc.Utils.TcType( isAmbiguousTyVar )
+import GHC.Core.TyCo.Compare( eqType, nonDetCmpType )
class DefaultType x (y :: x)
=====================================
testsuite/tests/pmcheck/should_compile/T11195.hs
=====================================
@@ -3,6 +3,7 @@
module T11195 where
import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.Coercion
import GHC.Core.Type hiding( substTyVarBndr, substTy, extendTCvSubst )
import GHC.Core.InstEnv
@@ -61,7 +62,7 @@ opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
opt_transList is = zipWith (opt_trans is)
opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
-opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2)
+opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2)
| d1 == d2
, co1 `compatible_co` co2 = undefined
=====================================
testsuite/tests/roles/should_compile/Roles3.stderr
=====================================
@@ -21,7 +21,7 @@ COERCION AXIOMS
axiom Roles3.N:C3 :: C3 a b = a -> F3 b -> F3 b
axiom Roles3.N:C4 :: C4 a b = a -> F4 b -> F4 b
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [base-4.17.0.0]
==================== Typechecker ====================
Roles3.$tcC4
@@ -48,24 +48,23 @@ Roles3.$tc'C:C1
= GHC.Types.TyCon
4508088879886988796##64 13962145553903222779##64 Roles3.$trModule
(GHC.Types.TrNameS "'C:C1"#) 1# $krep
+$krep [InlPrag=[~]]
+ = GHC.Types.KindRepTyConApp
+ GHC.Types.$tc~ ((:) GHC.Types.krep$* ((:) $krep ((:) $krep [])))
+$krep [InlPrag=[~]]
+ = GHC.Types.KindRepTyConApp Roles3.$tcC2 ((:) $krep ((:) $krep []))
+$krep [InlPrag=[~]]
+ = GHC.Types.KindRepTyConApp Roles3.$tcC1 ((:) $krep [])
$krep [InlPrag=[~]] = GHC.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Types.KindRepVar 1
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
-$krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep
-$krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
+$krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep
$krep [InlPrag=[~]]
- = GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint []
+ = GHC.Types.KindRepFun GHC.Types.krep$* GHC.Types.krep$Constraint
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
-$krep [InlPrag=[~]]
- = GHC.Types.KindRepTyConApp
- GHC.Types.$tc~ ((:) GHC.Types.krep$* ((:) $krep ((:) $krep [])))
-$krep [InlPrag=[~]]
- = GHC.Types.KindRepTyConApp Roles3.$tcC2 ((:) $krep ((:) $krep []))
-$krep [InlPrag=[~]]
- = GHC.Types.KindRepTyConApp Roles3.$tcC1 ((:) $krep [])
Roles3.$trModule
= GHC.Types.Module
(GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "Roles3"#)
=====================================
testsuite/tests/tcplugins/ArgsPlugin.hs
=====================================
@@ -17,7 +17,7 @@ import GHC.Core.DataCon
( classDataCon )
import GHC.Core.Make
( mkCoreConApps, mkIntegerExpr )
-import GHC.Core.Type
+import GHC.Core.TyCo.Compare
( eqType )
import GHC.Plugins
( Plugin )
=====================================
testsuite/tests/tcplugins/EmitWantedPlugin.hs
=====================================
@@ -19,7 +19,7 @@ import GHC.Core.DataCon
( classDataCon )
import GHC.Core.Make
( mkCoreConApps, unitExpr )
-import GHC.Core.Type
+import GHC.Core.TyCo.Compare
( eqType )
import GHC.Core.Utils
( mkCast )
=====================================
testsuite/tests/tcplugins/RewritePlugin.hs
=====================================
@@ -21,12 +21,14 @@ import GHC.Core.Predicate
)
import GHC.Core.Reduction
( Reduction(..) )
+import GHC.Core.TyCo.Compare
+ ( eqType )
import GHC.Core.TyCo.Rep
( Type, UnivCoProvenance(PluginProv) )
import GHC.Core.TyCon
( TyCon )
import GHC.Core.Type
- ( eqType, mkTyConApp, splitTyConApp_maybe )
+ ( mkTyConApp, splitTyConApp_maybe )
import GHC.Plugins
( Plugin )
import GHC.Tc.Plugin
=====================================
testsuite/tests/tcplugins/TyFamPlugin.hs
=====================================
@@ -19,10 +19,12 @@ import GHC.Core.Predicate
( EqRel(NomEq), Pred(EqPred)
, classifyPredType
)
+import GHC.Core.TyCo.Compare
+ ( eqType )
import GHC.Core.TyCo.Rep
( Type, UnivCoProvenance(PluginProv) )
import GHC.Core.Type
- ( eqType, mkTyConApp, splitTyConApp_maybe )
+ ( mkTyConApp, splitTyConApp_maybe )
import GHC.Plugins
( Plugin )
import GHC.Tc.Plugin
=====================================
testsuite/tests/typecheck/should_compile/T18406b.stderr
=====================================
@@ -17,20 +17,18 @@ Bug.$tc'C:C
= GHC.Types.TyCon
302756782745842909##64 14248103394115774781##64 Bug.$trModule
(GHC.Types.TrNameS "'C:C"#) 2# $krep
+$krep [InlPrag=[~]]
+ = GHC.Types.KindRepTyConApp
+ Bug.$tcC
+ ((:) @GHC.Types.KindRep
+ $krep ((:) @GHC.Types.KindRep $krep [] @GHC.Types.KindRep))
$krep [InlPrag=[~]] = GHC.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Types.KindRepVar 1
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep
-$krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep
$krep [InlPrag=[~]]
- = GHC.Types.KindRepTyConApp
- GHC.Types.$tcConstraint [] @GHC.Types.KindRep
-$krep [InlPrag=[~]]
- = GHC.Types.KindRepTyConApp
- Bug.$tcC
- ((:) @GHC.Types.KindRep
- $krep ((:) @GHC.Types.KindRep $krep [] @GHC.Types.KindRep))
+ = GHC.Types.KindRepFun GHC.Types.krep$* GHC.Types.krep$Constraint
Bug.$trModule
= GHC.Types.Module
(GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "Bug"#)
=====================================
testsuite/tests/typecheck/should_compile/T18529.stderr
=====================================
@@ -17,23 +17,21 @@ Bug.$tc'C:C
= GHC.Types.TyCon
302756782745842909##64 14248103394115774781##64 Bug.$trModule
(GHC.Types.TrNameS "'C:C"#) 2# $krep
+$krep [InlPrag=[~]]
+ = GHC.Types.KindRepTyConApp
+ Bug.$tcC
+ ((:) @GHC.Types.KindRep
+ $krep ((:) @GHC.Types.KindRep $krep [] @GHC.Types.KindRep))
$krep [InlPrag=[~]] = GHC.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Types.KindRepVar 1
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep
-$krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep
$krep [InlPrag=[~]]
- = GHC.Types.KindRepTyConApp
- GHC.Types.$tcConstraint [] @GHC.Types.KindRep
+ = GHC.Types.KindRepFun GHC.Types.krep$* GHC.Types.krep$Constraint
$krep [InlPrag=[~]]
= GHC.Types.KindRepTyConApp GHC.Tuple.$tc() [] @GHC.Types.KindRep
-$krep [InlPrag=[~]]
- = GHC.Types.KindRepTyConApp
- Bug.$tcC
- ((:) @GHC.Types.KindRep
- $krep ((:) @GHC.Types.KindRep $krep [] @GHC.Types.KindRep))
Bug.$trModule
= GHC.Types.Module
(GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "Bug"#)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e2f92c188c3936ef41e8382ea0ffa5c0201cf0c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e2f92c188c3936ef41e8382ea0ffa5c0201cf0c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220829/9d1a9e44/attachment-0001.html>
More information about the ghc-commits
mailing list