[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Linearise ghc-internal and base build
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Apr 25 22:20:28 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8a06ddf6 by Matthew Pickering at 2024-04-25T11:16:16-04:00
Linearise ghc-internal and base build
This is achieved by requesting the final package database for
ghc-internal, which mandates it is fully built as a dependency of
configuring the `base` package. This is at the expense of cross-package
parrallelism between ghc-internal and the base package.
Fixes #24436
- - - - -
94da9365 by Andrei Borzenkov at 2024-04-25T11:16:54-04:00
Fix tuple puns renaming (24702)
Move tuple renaming short cutter from `isBuiltInOcc_maybe` to `isPunOcc_maybe`, so we consider incoming module.
I also fixed some hidden bugs that raised after the change was done.
- - - - -
3e65cec9 by Alan Zimmerman at 2024-04-25T20:54:10+01:00
EPA: check-exact: check that the roundtrip reproduces the source
Closes #24670
- - - - -
482f827e by Andrew Lelechenko at 2024-04-25T18:20:20-04:00
Document that setEnv is not thread-safe
- - - - -
12 changed files:
- compiler/GHC/Builtin/Types.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- libraries/ghc-boot/GHC/Utils/Encoding.hs
- libraries/ghc-internal/src/GHC/Internal/System/Environment.hs
- libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- testsuite/tests/printer/PprExportWarn.hs
- + testsuite/tests/th/T24702a.hs
- + testsuite/tests/th/T24702b.hs
- testsuite/tests/th/TH_tuple1.stdout
- testsuite/tests/th/all.T
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -795,7 +795,7 @@ We make boxed one-tuple names have known keys so that `data Solo a = MkSolo a`,
defined in GHC.Tuple, will be used when one-tuples are spliced in through
Template Haskell. This program (from #18097) crucially relies on this:
- case $( tupE [ [| "ok" |] ] ) of Solo x -> putStrLn x
+ case $( tupE [ [| "ok" |] ] ) of MkSolo x -> putStrLn x
Unless Solo has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an
ExplicitTuple of length 1) will not match the type of Solo (an ordinary
@@ -838,26 +838,10 @@ isBuiltInOcc_maybe occ =
, (commas, rest') <- BS.span (==',') rest
, ")" <- rest'
-> Just $ tup_name Boxed (1+BS.length commas)
- _ | Just rest <- "Tuple" `BS.stripPrefix` name
- , Just (num, trailing) <- BS.readInt rest
- , num >= 2 && num <= 64
- -> if
- | BS.null trailing -> Just $ tup_name Boxed num
- | "#" == trailing -> Just $ tup_name Unboxed num
- | otherwise -> Nothing
-
- "CUnit" -> Just $ choose_ns (cTupleTyConName 0) (cTupleDataConName 0)
- "CSolo" -> Just $ choose_ns (cTupleTyConName 1) (cTupleDataConName 1)
- _ | Just rest <- "CTuple" `BS.stripPrefix` name
- , Just (num, trailing) <- BS.readInt rest
- , BS.null trailing
- , num >= 2 && num <= 64
- -> Just $ choose_ns (cTupleTyConName num) (cTupleDataConName num)
-- unboxed tuple data/tycon
"(##)" -> Just $ tup_name Unboxed 0
- "Unit#" -> Just $ tup_name Unboxed 0
- "Solo#" -> Just $ tup_name Unboxed 1
+ "(# #)" -> Just $ tup_name Unboxed 1
_ | Just rest <- "(#" `BS.stripPrefix` name
, (commas, rest') <- BS.span (==',') rest
, "#)" <- rest'
@@ -878,11 +862,6 @@ isBuiltInOcc_maybe occ =
-> let arity = nb_pipes1 + nb_pipes2 + 1
alt = nb_pipes1 + 1
in Just $ dataConName $ sumDataCon alt arity
- _ | Just rest <- "Sum" `BS.stripPrefix` name
- , Just (num, trailing) <- BS.readInt rest
- , num >= 2 && num <= 64
- , trailing == "#"
- -> Just $ tyConName $ sumTyCon num
_ -> Nothing
where
@@ -920,6 +899,21 @@ isTupleTyOcc_maybe mod occ
| otherwise = isTupleNTyOcc_maybe occ
isTupleTyOcc_maybe _ _ = Nothing
+isCTupleOcc_maybe :: Module -> OccName -> Maybe Name
+isCTupleOcc_maybe mod occ
+ | mod == gHC_CLASSES
+ = match_occ
+ where
+ match_occ
+ | occ == occName (cTupleTyConName 0) = Just (cTupleTyConName 0)
+ | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1)
+ | 'C':'T':'u':'p':'l':'e' : rest <- occNameString occ
+ , Just (BoxedTuple, num) <- arity_and_boxity rest
+ , num >= 2 && num <= 64
+ = Just $ cTupleTyConName num
+ | otherwise = Nothing
+
+isCTupleOcc_maybe _ _ = Nothing
-- | This is only for Tuple<n>, not for Unit or Solo
isTupleNTyOcc_maybe :: OccName -> Maybe Name
@@ -985,13 +979,12 @@ isPunOcc_maybe :: Module -> OccName -> Maybe Name
isPunOcc_maybe mod occ
| mod == gHC_TYPES, occ == occName listTyConName
= Just listTyConName
- | mod == gHC_INTERNAL_TUPLE, occ == occName unitTyConName
- = Just unitTyConName
- | mod == gHC_TYPES, occ == occName unboxedUnitTyConName
- = Just unboxedUnitTyConName
- | mod == gHC_INTERNAL_TUPLE || mod == gHC_TYPES
- = isTupleNTyOcc_maybe occ <|> isSumNTyOcc_maybe occ
-isPunOcc_maybe _ _ = Nothing
+ | mod == gHC_TYPES, occ == occName unboxedSoloDataConName
+ = Just unboxedSoloDataConName
+ | otherwise
+ = isTupleTyOcc_maybe mod occ <|>
+ isCTupleOcc_maybe mod occ <|>
+ isSumTyOcc_maybe mod occ
mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName
-- No need to cache these, the caching is done in mk_tuple
@@ -1304,6 +1297,8 @@ unboxedSoloTyCon = tupleTyCon Unboxed 1
unboxedSoloTyConName :: Name
unboxedSoloTyConName = tyConName unboxedSoloTyCon
+unboxedSoloDataConName :: Name
+unboxedSoloDataConName = tupleDataConName Unboxed 1
{- *********************************************************************
* *
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -71,6 +71,7 @@ import System.Directory (getCurrentDirectory)
import qualified Distribution.InstalledPackageInfo as CP
import Distribution.Simple.Utils (writeUTF8File)
import Utilities
+import Packages
-- | Parse the Cabal file of a given 'Package'. This operation is cached by the
@@ -150,8 +151,20 @@ configurePackage context at Context {..} = do
-- Stage packages are those we have in this stage.
stagePkgs <- stagePackages stage
+
+
+ -- Normally we will depend on Inplace package databases which enables
+ -- cross-package parallelism, but see #24436 for why we lineariese the build
+ -- of base and ghc-internal.
+ let forceBaseAfterGhcInternal dep =
+ if dep == ghcInternal && package == base
+ then Final
+ else iplace
+
+
+
-- We'll need those packages in our package database.
- deps <- sequence [ pkgConfFile (context { package = pkg })
+ deps <- sequence [ pkgConfFile (context { package = pkg, iplace = forceBaseAfterGhcInternal pkg })
| pkg <- depPkgs, pkg `elem` stagePkgs ]
need $ extraPreConfigureDeps ++ deps
=====================================
libraries/ghc-boot/GHC/Utils/Encoding.hs
=====================================
@@ -236,7 +236,6 @@ maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
(n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
_ -> Nothing
maybe_tuple "()" = Just("Z0T")
-maybe_tuple "MkSolo" = Just("Z1T")
maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of
(n, ')' : _) -> Just ('Z' : shows (n+1) "T")
_ -> Nothing
=====================================
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
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -1930,15 +1930,19 @@ mk_tup_name n space boxed
| boxed = "(" ++ thing ++ ")"
| otherwise = "(#" ++ thing ++ "#)"
tup_occ | n == 0, space == TcClsName = if boxed then "Unit" else "Unit#"
- | n == 1 = if boxed then solo else "Solo#"
+ | n == 1 = if boxed then solo else unboxed_solo
| space == TcClsName = "Tuple" ++ show n ++ if boxed then "" else "#"
| otherwise = withParens (replicate n_commas ',')
n_commas = n - 1
- tup_mod = mkModName (if boxed then "GHC.Tuple" else "GHC.Prim")
+ tup_mod = mkModName (if boxed then "GHC.Tuple" else "GHC.Types")
solo
| space == DataName = "MkSolo"
| otherwise = "Solo"
+ unboxed_solo
+ | space == DataName = "(# #)"
+ | otherwise = "Solo#"
+
-- Unboxed sum data and type constructors
-- | Unboxed sum data constructor
unboxedSumDataName :: SumAlt -> SumArity -> Name
=====================================
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/th/T24702a.hs
=====================================
@@ -0,0 +1,55 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedTuples #-}
+module T24702a where
+
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax
+
+$(do
+ let
+ step = \acc n -> acc `appT` n
+ args n = replicate n (conT ''Int)
+
+ mkTupleTest mkTupTy mkTupCon boxity n = do
+ let
+ nil = conT (mkTupTy n)
+ tup = foldl step nil (args n)
+ f <- newName (boxity <> show n)
+
+ -- f<n> :: (,,..n..,,) t1 t2 .. tn -> ()
+ -- f<n> = \ (_, _, ...n..., _) -> ()
+ sequence $
+ sigD f [t|$(tup) -> ()|] :
+ valD (varP f) (normalB [e| \ $(conP (mkTupCon n) (replicate n wildP)) -> ()|]) [] :
+ []
+
+ mkSumTest n = do
+ let
+ nil = conT (unboxedSumTypeName n)
+ sumTy = foldl step nil (args n)
+ mkSumAlt altN =
+ let sumDataCon = unboxedSumDataName altN n
+ varName = mkName "x" in
+ clause [conP sumDataCon [varP varName]]
+ (normalB (conE sumDataCon `appE` varE varName)) []
+ f <- newName ("sum" <> show n)
+
+ -- f<n> :: (#||...n...||#) -> (#||...n...||#)
+ -- f<n> (x||...n...||) = (x||...n...||)
+ -- f<n> (|x||...n...||) = (|x||...n...||)
+ -- ...n...
+ -- f<n> (||...n...||x) = (||...n...||x)
+ sequence $
+ sigD f [t|$(sumTy) -> $(sumTy)|] :
+ funD f (map mkSumAlt [1 .. n]) :
+ []
+
+ newDeclarationGroup <>
+ mkTupleTest
+ unboxedTupleTypeName unboxedTupleDataName "unboxed"
+ `foldMap` (64 : [0 .. 8]) <>
+ mkTupleTest
+ tupleTypeName tupleDataName "boxed"
+ `foldMap` (64 : [0 .. 8]) <>
+ mkSumTest
+ `foldMap` (63 : [2 .. 8]) )
=====================================
testsuite/tests/th/T24702b.hs
=====================================
@@ -0,0 +1,44 @@
+{-# LANGUAGE TemplateHaskell, MagicHash #-}
+module T24702b where
+
+import Language.Haskell.TH
+
+data Unit = MkUnit
+tup0 :: $(conT (mkName "Unit"))
+tup0 = MkUnit
+
+data Solo = MkSolo
+tup1 :: $(conT (mkName "Solo"))
+tup1 = MkSolo
+
+data Tuple2 = MkTuple2
+tup2 :: $(conT (mkName "Tuple2"))
+tup2 = MkTuple2
+
+data CUnit = MkCUnit
+ctup0 :: $(conT (mkName "CUnit"))
+ctup0 = MkCUnit
+
+data CSolo = MkCSolo
+ctup1 :: $(conT (mkName "CSolo"))
+ctup1 = MkCSolo
+
+data CTuple2 = MkCTuple2
+ctup2 :: $(conT (mkName "CTuple2"))
+ctup2 = MkCTuple2
+
+data Unit# = MkUnit#
+utup0 :: $(conT (mkName "Unit#"))
+utup0 = MkUnit#
+
+data Solo# = MkSolo#
+utup1 :: $(conT (mkName "Solo#"))
+utup1 = MkSolo#
+
+data Tuple2# = MkTuple2#
+utup2 :: $(conT (mkName "Tuple2#"))
+utup2 = MkTuple2#
+
+data Sum2# = MkSum2#
+sum2 :: $(conT (mkName "Sum2#"))
+sum2 = MkSum2#
=====================================
testsuite/tests/th/TH_tuple1.stdout
=====================================
@@ -3,8 +3,8 @@ GHC.Tuple.(,) 1 2 :: GHC.Tuple.Tuple2 GHC.Num.Integer.Integer
GHC.Num.Integer.Integer
SigE (AppE (ConE GHC.Tuple.MkSolo) (LitE (IntegerL 1))) (AppT (ConT GHC.Tuple.Solo) (ConT GHC.Num.Integer.Integer))
GHC.Tuple.MkSolo 1 :: GHC.Tuple.Solo GHC.Num.Integer.Integer
-SigE (AppE (AppE (ConE GHC.Prim.(#,#)) (LitE (IntegerL 1))) (LitE (IntegerL 2))) (AppT (AppT (ConT GHC.Prim.Tuple2#) (ConT GHC.Num.Integer.Integer)) (ConT GHC.Num.Integer.Integer))
-GHC.Prim.(#,#) 1 2 :: GHC.Prim.Tuple2# GHC.Num.Integer.Integer
- GHC.Num.Integer.Integer
-SigE (AppE (ConE GHC.Prim.Solo#) (LitE (IntegerL 1))) (AppT (ConT GHC.Prim.Solo#) (ConT GHC.Num.Integer.Integer))
-GHC.Prim.Solo# 1 :: GHC.Prim.Solo# GHC.Num.Integer.Integer
+SigE (AppE (AppE (ConE GHC.Types.(#,#)) (LitE (IntegerL 1))) (LitE (IntegerL 2))) (AppT (AppT (ConT GHC.Types.Tuple2#) (ConT GHC.Num.Integer.Integer)) (ConT GHC.Num.Integer.Integer))
+GHC.Types.(#,#) 1 2 :: GHC.Types.Tuple2# GHC.Num.Integer.Integer
+ GHC.Num.Integer.Integer
+SigE (AppE (ConE GHC.Types.(# #)) (LitE (IntegerL 1))) (AppT (ConT GHC.Types.Solo#) (ConT GHC.Num.Integer.Integer))
+GHC.Types.(# #) 1 :: GHC.Types.Solo# GHC.Num.Integer.Integer
=====================================
testsuite/tests/th/all.T
=====================================
@@ -612,3 +612,5 @@ test('T24557b', normal, compile_fail, [''])
test('T24557c', normal, compile_fail, [''])
test('T24557d', normal, compile_fail, [''])
test('T24557e', normal, compile, [''])
+test('T24702a', normal, compile, [''])
+test('T24702b', normal, compile, [''])
=====================================
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/02536948764b4e33169623b4230a3abccfcb430e...482f827e98fe693d882dc908eaceeabab0fa7ee5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/02536948764b4e33169623b4230a3abccfcb430e...482f827e98fe693d882dc908eaceeabab0fa7ee5
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/20240425/ae1edf8e/attachment-0001.html>
More information about the ghc-commits
mailing list