[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Fix missing escaping-kind check in tcPatSynSig
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Apr 26 10:32:24 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e64e95b4 by Simon Peyton Jones at 2024-04-26T06:32:12-04:00
Fix missing escaping-kind check in tcPatSynSig
Note [Escaping kind in type signatures] explains how we deal
with escaping kinds in type signatures, e.g.
f :: forall r (a :: TYPE r). a
where the kind of the body is (TYPE r), but `r` is not in
scope outside the forall-type.
I had missed this subtlety in tcPatSynSig, leading to #24686.
This MR fixes it; and a similar bug in tc_top_lhs_type. (The
latter is tested by T24686a.)
- - - - -
98ad7b99 by Alan Zimmerman at 2024-04-26T06:32:13-04:00
EPA: check-exact: check that the roundtrip reproduces the source
Closes #24670
- - - - -
6c1aed88 by Andrew Lelechenko at 2024-04-26T06:32:13-04:00
Document that setEnv is not thread-safe
- - - - -
12 changed files:
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Sig.hs
- libraries/ghc-internal/src/GHC/Internal/System/Environment.hs
- libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc
- + testsuite/tests/polykinds/T24686.hs
- + testsuite/tests/polykinds/T24686.stderr
- + testsuite/tests/polykinds/T24686a.hs
- + testsuite/tests/polykinds/T24686a.stderr
- testsuite/tests/polykinds/all.T
- testsuite/tests/printer/PprExportWarn.hs
- testsuite/tests/rep-poly/RepPolyPatSynRes.stderr
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -56,7 +56,7 @@ module GHC.Tc.Gen.HsType (
tcHsLiftedType, tcHsOpenType,
tcHsLiftedTypeNC, tcHsOpenTypeNC,
tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,
- tcCheckLHsTypeInContext,
+ tcCheckLHsTypeInContext, tcCheckLHsType,
tcHsContext, tcLHsPredType,
kindGeneralizeAll,
@@ -496,7 +496,7 @@ tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs
{- Note [Escaping kind in type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider kind-checking the signature for `foo` (#19495):
+Consider kind-checking the signature for `foo` (#19495, #24686):
type family T (r :: RuntimeRep) :: TYPE r
foo :: forall (r :: RuntimeRep). T r
@@ -508,7 +508,8 @@ because we allow signatures like `foo :: Int#`.)
Suppose we are at level L currently. We do this
* pushLevelAndSolveEqualitiesX: moves to level L+1
- * newExpectedKind: allocates delta{L+1}
+ * newExpectedKind: allocates delta{L+1}. Note carefully that
+ this call is /outside/ the tcOuterTKBndrs call.
* tcOuterTKBndrs: pushes the level again to L+2, binds skolem r{L+2}
* kind-check the body (T r) :: TYPE delta{L+1}
@@ -607,9 +608,9 @@ tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs
; skol_info <- mkSkolemInfo skol_info_anon
; (tclvl, wanted, (outer_bndrs, ty))
<- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $
- tcOuterTKBndrs skol_info hs_outer_bndrs $
do { kind <- newExpectedKind (expectedKindInCtxt ctxt)
- ; tc_check_lhs_type (mkMode tyki) body kind }
+ ; tcOuterTKBndrs skol_info hs_outer_bndrs $
+ tc_check_lhs_type (mkMode tyki) body kind }
; outer_bndrs <- scopedSortOuter outer_bndrs
; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -36,7 +36,7 @@ import GHC.Tc.Gen.HsType
import GHC.Tc.Types
import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep )
+import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep, newOpenTypeKind )
import GHC.Tc.Zonk.Type
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
@@ -386,14 +386,16 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty
; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty))))
<- pushLevelAndSolveEqualitiesX "tcPatSynSig" $
-- See Note [Report unsolved equalities in tcPatSynSig]
- tcOuterTKBndrs skol_info hs_outer_bndrs $
- tcExplicitTKBndrs skol_info ex_hs_tvbndrs $
- do { req <- tcHsContext hs_req
- ; prov <- tcHsContext hs_prov
- ; body_ty <- tcHsOpenType hs_body_ty
- -- A (literal) pattern can be unlifted;
- -- e.g. pattern Zero <- 0# (#12094)
- ; return (req, prov, body_ty) }
+ do { res_kind <- newOpenTypeKind
+ -- "open" because a (literal) pattern can be unlifted;
+ -- e.g. pattern Zero <- 0# (#12094)
+ -- See Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType
+ ; tcOuterTKBndrs skol_info hs_outer_bndrs $
+ tcExplicitTKBndrs skol_info ex_hs_tvbndrs $
+ do { req <- tcHsContext hs_req
+ ; prov <- tcHsContext hs_prov
+ ; body_ty <- tcCheckLHsType hs_body_ty res_kind
+ ; return (req, prov, body_ty) } }
; let implicit_tvs :: [TcTyVar]
univ_bndrs :: [TcInvisTVBinder]
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Environment.hs
=====================================
@@ -225,6 +225,13 @@ ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
-- Throws `Control.Exception.IOException` if @name@ is the empty string or
-- contains an equals sign.
--
+-- Beware that this function must not be executed concurrently
+-- with 'getEnv', 'lookupEnv', 'getEnvironment' and such. One thread
+-- reading environment variables at the same time with another one modifying them
+-- can result in a segfault, see
+-- [Setenv is not Thread Safe](https://www.evanjones.ca/setenv-is-not-thread-safe.html)
+-- for discussion.
+--
-- @since base-4.7.0.0
setEnv :: String -> String -> IO ()
setEnv key_ value_
@@ -269,6 +276,13 @@ foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
-- Throws `Control.Exception.IOException` if @name@ is the empty string or
-- contains an equals sign.
--
+-- Beware that this function must not be executed concurrently
+-- with 'getEnv', 'lookupEnv', 'getEnvironment' and such. One thread
+-- reading environment variables at the same time with another one modifying them
+-- can result in a segfault, see
+-- [Setenv is not Thread Safe](https://www.evanjones.ca/setenv-is-not-thread-safe.html)
+-- for discussion.
+--
-- @since base-4.7.0.0
unsetEnv :: String -> IO ()
#if defined(mingw32_HOST_OS)
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc
=====================================
@@ -109,6 +109,13 @@ getEnvDefault name fallback = fromMaybe fallback <$> getEnv name
-- | Like 'GHC.Internal.System.Environment.setEnv', but allows blank environment values
-- and mimics the function signature of 'System.Posix.Env.setEnv' from the
-- @unix@ package.
+--
+-- Beware that this function must not be executed concurrently
+-- with 'getEnv', 'lookupEnv', 'getEnvironment' and such. One thread
+-- reading environment variables at the same time with another one modifying them
+-- can result in a segfault, see
+-- [Setenv is not Thread Safe](https://www.evanjones.ca/setenv-is-not-thread-safe.html)
+-- for discussion.
setEnv ::
String {- ^ variable name -} ->
String {- ^ variable value -} ->
@@ -151,6 +158,13 @@ foreign import ccall unsafe "setenv"
-- | Like 'GHC.Internal.System.Environment.unsetEnv', but allows for the removal of
-- blank environment variables. May throw an exception if the underlying
-- platform doesn't support unsetting of environment variables.
+--
+-- Beware that this function must not be executed concurrently
+-- with 'getEnv', 'lookupEnv', 'getEnvironment' and such. One thread
+-- reading environment variables at the same time with another one modifying them
+-- can result in a segfault, see
+-- [Setenv is not Thread Safe](https://www.evanjones.ca/setenv-is-not-thread-safe.html)
+-- for discussion.
unsetEnv :: String -> IO ()
#if defined(mingw32_HOST_OS)
unsetEnv key = withCWString key $ \k -> do
=====================================
testsuite/tests/polykinds/T24686.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE ViewPatterns, PatternSynonyms #-}
+module T24686 where
+
+import GHC.Exts
+import GHC.Stack
+
+{-
+ on GHC 9.4 / 9.6 / 9.8 this panics with
+ <no location info>: error:
+ panic! (the 'impossible' happened)
+ GHC version 9.4.8:
+ typeKind
+ forall {r :: RuntimeRep} (a :: TYPE r). a
+ [r_aNu, a_aNy]
+ a_aNy :: TYPE r_aNu
+ Call stack:
+ CallStack (from HasCallStack):
+ callStackDoc, called at compiler/GHC/Utils/Panic.hs:182:37 in ghc:GHC.Utils.Panic
+ pprPanic, called at compiler/GHC/Core/Type.hs:3059:18 in ghc:GHC.Core.Type
+
+ This regression test exists to make sure the fix introduced between 9.8 and 9.11 does not get removed
+ again.
+-}
+
+pattern Bug :: forall. HasCallStack => forall {r :: RuntimeRep} (a :: TYPE r). a
+pattern Bug <- (undefined -> _unused)
+ where
+ Bug = undefined
=====================================
testsuite/tests/polykinds/T24686.stderr
=====================================
@@ -0,0 +1,7 @@
+
+T24686.hs:25:80: error: [GHC-25897]
+ Couldn't match kind ‘r’ with ‘LiftedRep’
+ Expected kind ‘*’, but ‘a’ has kind ‘TYPE r’
+ ‘r’ is a rigid type variable bound by
+ the type signature for ‘Bug’
+ at T24686.hs:25:48
=====================================
testsuite/tests/polykinds/T24686a.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE StandaloneKindSignatures #-}
+module T24686a where
+
+import GHC.Exts
+
+-- This one crashed GHC too: see #24686
+
+type T :: forall a (b:: TYPE a). b
+data T
=====================================
testsuite/tests/polykinds/T24686a.stderr
=====================================
@@ -0,0 +1,8 @@
+
+T24686a.hs:8:34: error: [GHC-25897]
+ • Couldn't match kind ‘a’ with ‘LiftedRep’
+ Expected kind ‘*’, but ‘b’ has kind ‘TYPE a’
+ ‘a’ is a rigid type variable bound by
+ a standalone kind signature for ‘T’
+ at T24686a.hs:8:18
+ • In a standalone kind signature for ‘T’: forall a (b :: TYPE a). b
=====================================
testsuite/tests/polykinds/all.T
=====================================
@@ -245,3 +245,5 @@ test('T22742', normal, compile_fail, [''])
test('T22793', normal, compile_fail, [''])
test('T24083', normal, compile_fail, [''])
test('T24083a', normal, compile, [''])
+test('T24686', normal, compile_fail, [''])
+test('T24686a', normal, compile_fail, [''])
=====================================
testsuite/tests/printer/PprExportWarn.hs
=====================================
@@ -6,12 +6,12 @@ module PprExportWarning (
reallyreallyreallyreallyreallyreallyreallyreallylongname,
{-# DEPRECATED "Just because" #-} Bar(Bar1, Bar2),
{-# WARNING "Just because" #-} name,
- {-# DEPRECATED ["Reason",
- "Another reason"] #-}
+ {-# DEPRECATED ["Reason",
+ "Another reason"] #-}
Baz,
{-# DEPRECATED [ ] #-} module GHC,
{-# WARNING "Dummy Pattern" #-} pattern Dummy,
- Foo'(..),
+ Foo'(..),
reallyreallyreallyreallyreallyreallyreallyreallylongname',
Bar'(Bar1, Bar2), name', Baz', module Data.List, pattern Dummy'
) where
=====================================
testsuite/tests/rep-poly/RepPolyPatSynRes.stderr
=====================================
@@ -1,4 +1,7 @@
-RepPolyPatSynRes.hs:13:1: error: [GHC-18478]
- The pattern synonym scrutinee does not have a fixed runtime representation:
- • a :: TYPE rep
+RepPolyPatSynRes.hs:13:59: error: [GHC-25897]
+ Couldn't match kind ‘rep’ with ‘LiftedRep’
+ Expected kind ‘*’, but ‘a’ has kind ‘TYPE rep’
+ ‘rep’ is a rigid type variable bound by
+ the type signature for ‘Pat’
+ at RepPolyPatSynRes.hs:13:23-25
=====================================
utils/check-exact/Main.hs
=====================================
@@ -319,8 +319,10 @@ testOneFile _ libdir fileName mchanger = do
expectedSource <- readFile newFileExpected
changedSource <- readFile newFileChanged
return (expectedSource == changedSource, expectedSource, changedSource)
- Nothing -> return (True, "", "")
-
+ Nothing -> do
+ expectedSource <- readFile fileName
+ changedSource <- readFile newFile
+ return (expectedSource == changedSource, expectedSource, changedSource)
(p',_) <- parseOneFile libdir newFile
let newAstStr :: String
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4ceb6077ff4f599a6ae2a757470db546caa7cb41...6c1aed888135517684d0eb07096ce99d5ac61413
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4ceb6077ff4f599a6ae2a757470db546caa7cb41...6c1aed888135517684d0eb07096ce99d5ac61413
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/20240426/81d7a5f5/attachment-0001.html>
More information about the ghc-commits
mailing list