[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Simplify and correct nasty case in coercion opt
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Oct 2 17:36:33 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
bc204783 by Richard Eisenberg at 2023-10-02T14:50:52+02:00
Simplify and correct nasty case in coercion opt
This fixes #21062.
No test case, because triggering this code seems challenging.
- - - - -
c14a420c by Andrew Lelechenko at 2023-10-02T13:36:23-04:00
Bump bytestring submodule to 0.12.0.2
- - - - -
7ee29cdb by Andrew Lelechenko at 2023-10-02T13:36:23-04:00
Inline bucket_match
- - - - -
cabaaafd by sheaf at 2023-10-02T13:36:26-04:00
Fix non-symbolic children lookup of fixity decl
The fix for #23664 did not correctly account for non-symbolic names
when looking up children of a given parent. This one-line fix changes
that.
Fixes #24037
- - - - -
15 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- hadrian/hadrian.cabal
- libraries/bytestring
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-compact/ghc-compact.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- + testsuite/tests/rename/should_compile/T24037.hs
- testsuite/tests/rename/should_compile/all.T
- utils/iserv/iserv.cabal.in
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -95,10 +95,10 @@ module GHC.Core.Coercion (
-- ** Lifting
liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,
emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,
- liftCoSubstVarBndrUsing, isMappedByLC,
+ liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst,
mkSubstLiftingContext, zapLiftingContext,
- substForAllCoBndrUsingLC, lcSubst, lcInScopeSet,
+ substForAllCoBndrUsingLC, lcLookupCoVar, lcInScopeSet,
LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,
substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,
@@ -1991,6 +1991,15 @@ extendLiftingContext (LC subst env) tv arg
| otherwise
= LC subst (extendVarEnv env tv arg)
+-- | Extend the substitution component of a lifting context with
+-- a new binding for a coercion variable. Used during coercion optimisation.
+extendLiftingContextCvSubst :: LiftingContext
+ -> CoVar
+ -> Coercion
+ -> LiftingContext
+extendLiftingContextCvSubst (LC subst env) cv co
+ = LC (extendCvSubst subst cv co) env
+
-- | Extend a lifting context with a new mapping, and extend the in-scope set
extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC
-> TyCoVar -- ^ new variable to map...
@@ -2298,9 +2307,9 @@ liftEnvSubst selector subst lc_env
where
equality_ty = selector (coercionKind co)
--- | Extract the underlying substitution from the LiftingContext
-lcSubst :: LiftingContext -> Subst
-lcSubst (LC subst _) = subst
+-- | Lookup a 'CoVar' in the substitution in a 'LiftingContext'
+lcLookupCoVar :: LiftingContext -> CoVar -> Maybe Coercion
+lcLookupCoVar (LC subst _) cv = lookupCoVar subst cv
-- | Get the 'InScopeSet' from a 'LiftingContext'
lcInScopeSet :: LiftingContext -> InScopeSet
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -310,14 +310,15 @@ opt_co4 env sym rep r (FunCo _r afl afr cow co1 co2)
!(afl', afr') = swapSym sym (afl, afr)
opt_co4 env sym rep r (CoVarCo cv)
- | Just co <- lookupCoVar (lcSubst env) cv
+ | Just co <- lcLookupCoVar env cv -- see Note [Forall over coercion] for why
+ -- this is the right thing here
= opt_co4_wrap (zapLiftingContext env) sym rep r co
| ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl]
= mkReflCo (chooseRole rep r) ty1
| otherwise
- = assert (isCoVar cv1 )
+ = assert (isCoVar cv1) $
wrapRole rep r $ wrapSym sym $
CoVarCo cv1
@@ -414,6 +415,40 @@ opt_co4 env sym rep r (LRCo lr co)
pick_lr CLeft (l, _) = l
pick_lr CRight (_, r) = r
+{-
+Note [Forall over coercion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example:
+ type (:~:) :: forall k. k -> k -> Type
+ Refl :: forall k (a :: k) (b :: k). forall (cv :: (~#) k k a b). (:~:) k a b
+ k1,k2,k3,k4 :: Type
+ eta :: (k1 ~# k2) ~# (k3 ~# k4) == ((~#) Type Type k1 k2) ~# ((~#) Type Type k3 k4)
+ co1_3 :: k1 ~# k3
+ co2_4 :: k2 ~# k4
+ nth 2 eta :: k1 ~# k3
+ nth 3 eta :: k2 ~# k4
+ co11_31 :: <k1> ~# (sym co1_3)
+ co22_24 :: <k2> ~# co2_4
+ (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) ::
+ (forall (cv :: k1 ~# k2). Refl Type k1 k2 (<k1> ;; cv ;; <k2>) ~#
+ (forall (cv :: k3 ~# k4). Refl Type k3 k4
+ (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))
+ co1_2 :: k1 ~# k2
+ co3_4 :: k3 ~# k4
+ co5 :: co1_2 ~# co3_4
+ InstCo (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) co5 ::
+ (Refl Type k1 k2 (<k1> ;; cv ;; <k2>))[cv |-> co1_2] ~#
+ (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))[cv |-> co3_4]
+ ==
+ (Refl Type k1 k2 (<k1> ;; co1_2 ;; <k2>)) ~#
+ (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; co3_4 ;; sym (nth 3 eta) ;; co2_4))
+ ==>
+ Refl <Type> co1_3 co2_4 (co11_31 ;; co1_2 ;; co22_24)
+Conclusion: Because of the way this all works, we want to put in the *left-hand*
+coercion in co5's type. (In the code, co5 is called `arg`.)
+So we extend the environment binding cv to arg's left-hand type.
+-}
+
-- See Note [Optimising InstCo]
opt_co4 env sym rep r (InstCo co1 arg)
-- forall over type...
@@ -425,12 +460,10 @@ opt_co4 env sym rep r (InstCo co1 arg)
-- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1)
sym rep r co_body
- -- forall over coercion...
- | Just (cv, _visL, _visR, kind_co, co_body) <- splitForAllCo_co_maybe co1
+ -- See Note [Forall over coercion]
+ | Just (cv, _visL, _visR, _kind_co, co_body) <- splitForAllCo_co_maybe co1
, CoercionTy h1 <- t1
- , CoercionTy h2 <- t2
- = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2
- in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body
+ = opt_co4_wrap (extendLiftingContextCvSubst env cv h1) sym rep r co_body
-- See if it is a forall after optimization
-- If so, do an inefficient one-variable substitution, then re-optimize
@@ -441,12 +474,10 @@ opt_co4 env sym rep r (InstCo co1 arg)
(mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg'))
False False r' co_body'
- -- forall over coercion...
- | Just (cv', _visL, _visR, kind_co', co_body') <- splitForAllCo_co_maybe co1'
+ -- See Note [Forall over coercion]
+ | Just (cv', _visL, _visR, _kind_co', co_body') <- splitForAllCo_co_maybe co1'
, CoercionTy h1' <- t1'
- , CoercionTy h2' <- t2'
- = let new_co = mk_new_co cv' kind_co' h1' h2'
- in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co)
+ = opt_co4_wrap (extendLiftingContextCvSubst (zapLiftingContext env) cv' h1')
False False r' co_body'
| otherwise = InstCo co1' arg'
@@ -467,20 +498,6 @@ opt_co4 env sym rep r (InstCo co1 arg)
Pair t1 t2 = coercionKind sym_arg
Pair t1' t2' = coercionKind arg'
- mk_new_co cv kind_co h1 h2
- = let -- h1 :: (t1 ~ t2)
- -- h2 :: (t3 ~ t4)
- -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4)
- -- n1 :: t1 ~ t3
- -- n2 :: t2 ~ t4
- -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2)
- r2 = coVarRole cv
- kind_co' = downgradeRole r2 Nominal kind_co
- n1 = mkSelCo (SelTyCon 2 r2) kind_co'
- n2 = mkSelCo (SelTyCon 3 r2) kind_co'
- in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1
- (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))
-
opt_co4 env sym _rep r (KindCo co)
= assert (r == Nominal) $
let kco' = promoteCoercion co in
=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -506,6 +506,10 @@ bucket_match fs sbs = go fs
go (fs@(FastString {fs_sbs=fs_sbs}) : ls)
| fs_sbs == sbs = Just fs
| otherwise = go ls
+-- bucket_match used to inline before changes to instance Eq ShortByteString
+-- in bytestring-0.12, which made it slighhtly larger than inlining threshold.
+-- Non-inlining causes a small, but measurable performance regression, so let's force it.
+{-# INLINE bucket_match #-}
mkFastStringBytes :: Ptr Word8 -> Int -> FastString
mkFastStringBytes !ptr !len =
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -1308,12 +1308,16 @@ childGREPriority (LookupChild { wantedParent = wanted_parent
| isTermVarOrFieldNameSpace ns
, isTermVarOrFieldNameSpace other_ns
= Just 0
- | ns == varName
+ | isValNameSpace varName
, other_ns == tcName
- -- When looking up children, we sometimes want to a symbolic variable
- -- name to resolve to a type constructor, e.g. for an infix declaration
- -- "infix +!" we want to take into account both class methods and associated
- -- types. See test T10816.
+ -- When looking up children, we sometimes want a value name
+ -- to resolve to a type constructor.
+ -- For example, for an infix declaration "infixr 3 +!" or "infix 2 `Fun`"
+ -- inside a class declaration, we want to account for the possibility
+ -- that the identifier refers to an associated type (type constructor
+ -- NameSpace), when otherwise "+!" would be in the term-level variable
+ -- NameSpace, and "Fun" would be in the term-level data constructor
+ -- NameSpace. See tests T10816, T23664, T24037.
= Just 1
| ns == tcName
, other_ns == dataName
=====================================
compiler/ghc.cabal.in
=====================================
@@ -98,7 +98,7 @@ Library
deepseq >= 1.4 && < 1.6,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
- bytestring >= 0.9 && < 0.12,
+ bytestring >= 0.9 && < 0.13,
binary == 0.8.*,
time >= 1.4 && < 1.13,
containers >= 0.6.2.1 && < 0.7,
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -33,7 +33,7 @@ Executable ghc
Main-Is: Main.hs
Build-Depends: base >= 4 && < 5,
array >= 0.1 && < 0.6,
- bytestring >= 0.9 && < 0.12,
+ bytestring >= 0.9 && < 0.13,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
filepath >= 1 && < 1.5,
=====================================
hadrian/hadrian.cabal
=====================================
@@ -153,7 +153,7 @@ executable hadrian
, TypeFamilies
build-depends: Cabal >= 3.10 && < 3.11
, base >= 4.11 && < 5
- , bytestring >= 0.10 && < 0.12
+ , bytestring >= 0.10 && < 0.13
, containers >= 0.5 && < 0.7
, directory >= 1.3.1.0 && < 1.4
, extra >= 1.4.7
=====================================
libraries/bytestring
=====================================
@@ -1 +1 @@
-Subproject commit 2bdeb7b0e7dd100fce9e1f4d1ecf1cd6b5b9702c
+Subproject commit 39f40116a4adf8a3296067d64bd00e1a1e5e15bd
=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -75,7 +75,7 @@ Library
build-depends: base >= 4.7 && < 4.20,
binary == 0.8.*,
- bytestring >= 0.10 && < 0.12,
+ bytestring >= 0.10 && < 0.13,
containers >= 0.5 && < 0.7,
directory >= 1.2 && < 1.4,
filepath >= 1.3 && < 1.5,
=====================================
libraries/ghc-compact/ghc-compact.cabal
=====================================
@@ -41,7 +41,7 @@ library
build-depends: ghc-prim >= 0.5.3 && < 0.11,
base >= 4.9.0 && < 4.20,
- bytestring >= 0.10.6.0 && <0.12
+ bytestring >= 0.10.6.0 && <0.13
ghc-options: -Wall
exposed-modules: GHC.Compact
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -78,7 +78,7 @@ library
base >= 4.8 && < 4.20,
ghc-prim >= 0.5.0 && < 0.11,
binary == 0.8.*,
- bytestring >= 0.10 && < 0.12,
+ bytestring >= 0.10 && < 0.13,
containers >= 0.5 && < 0.7,
deepseq >= 1.4 && < 1.6,
filepath == 1.4.*,
=====================================
libraries/haskeline
=====================================
@@ -1 +1 @@
-Subproject commit 0ea07e223685787893dccbcbb67f1720ef4cf80e
+Subproject commit 16ee820fc86f43045365f2c3536ad18147eb0b79
=====================================
testsuite/tests/rename/should_compile/T24037.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies, TypeOperators #-}
+
+module T24037 where
+
+class POrd a where
+ type Geq a b
+ infixr 6 `Geq`
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -215,6 +215,7 @@ test('T23434', normal, compile, [''])
test('T23510b', normal, compile, [''])
test('T23512b', normal, compile, [''])
test('T23664', normal, compile, [''])
+test('T24037', normal, compile, [''])
test('ExportWarnings1', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs']), multimod_compile, ['ExportWarnings1', '-v0 -Wno-duplicate-exports -Wx-custom'])
test('ExportWarnings2', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs', 'ExportWarnings_aux2.hs']), multimod_compile, ['ExportWarnings2', '-v0 -Wno-duplicate-exports -Wx-custom'])
test('ExportWarnings3', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs']), multimod_compile, ['ExportWarnings3', '-v0 -Wno-duplicate-exports -Wx-custom'])
=====================================
utils/iserv/iserv.cabal.in
=====================================
@@ -33,7 +33,7 @@ Executable iserv
Build-Depends: array >= 0.5 && < 0.6,
base >= 4 && < 5,
binary >= 0.7 && < 0.11,
- bytestring >= 0.10 && < 0.12,
+ bytestring >= 0.10 && < 0.13,
containers >= 0.5 && < 0.7,
deepseq >= 1.4 && < 1.6,
ghci == @ProjectVersionMunged@
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8d4df58cc3161daa9f0a7ea9b04d01a6b52391a...cabaaafd76895ef714ff459abe9e447593bdfd34
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8d4df58cc3161daa9f0a7ea9b04d01a6b52391a...cabaaafd76895ef714ff459abe9e447593bdfd34
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/20231002/9dcf6a8c/attachment-0001.html>
More information about the ghc-commits
mailing list