[Git][ghc/ghc][wip/az/T24670-epa-compare-source] 8 commits: ghc-bignum: remove obsolete ln script
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Thu Apr 25 19:54:25 UTC 2024
Alan Zimmerman pushed to branch wip/az/T24670-epa-compare-source at Glasgow Haskell Compiler / GHC
Commits:
c62dc317 by Cheng Shao at 2024-04-25T01:32:02-04:00
ghc-bignum: remove obsolete ln script
This commit removes an obsolete ln script in ghc-bignum/gmp. See
060251c24ad160264ae8553efecbb8bed2f06360 for its original intention,
but it's been obsolete for a long time, especially since the removal
of the make build system. Hence the house cleaning.
- - - - -
6399d52b by Cheng Shao at 2024-04-25T01:32:02-04:00
ghc-bignum: update gmp to 6.3.0
This patch bumps the gmp-tarballs submodule and updates gmp to 6.3.0.
The tarball format is now xz, and gmpsrc.patch has been patched into
the tarball so hadrian no longer needs to deal with patching logic
when building in-tree GMP.
- - - - -
65b4b92f by Cheng Shao at 2024-04-25T01:32:02-04:00
hadrian: remove obsolete Patch logic
This commit removes obsolete Patch logic from hadrian, given we no
longer need to patch the gmp tarball when building in-tree GMP.
- - - - -
71f28958 by Cheng Shao at 2024-04-25T01:32:02-04:00
autoconf: remove obsolete patch detection
This commit removes obsolete deletection logic of the patch command
from autoconf scripts, given we no longer need to patch anything in
the GHC build process.
- - - - -
daeda834 by Sylvain Henry at 2024-04-25T01:32:43-04:00
JS: correctly handle RUBBISH literals (#24664)
- - - - -
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
- - - - -
18 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/StgToJS/Literal.hs
- configure.ac
- hadrian/cfg/system.config.in
- hadrian/src/Builder.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Rules/Gmp.hs
- libraries/ghc-bignum/gmp/gmp-tarballs
- − libraries/ghc-bignum/gmp/gmpsrc.patch
- − libraries/ghc-bignum/gmp/ln
- libraries/ghc-boot/GHC/Utils/Encoding.hs
- 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
{- *********************************************************************
* *
=====================================
compiler/GHC/StgToJS/Literal.hs
=====================================
@@ -22,6 +22,7 @@ import GHC.StgToJS.Symbols
import GHC.Data.FastString
import GHC.Types.Literal
import GHC.Types.Basic
+import GHC.Types.RepType
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
@@ -68,7 +69,27 @@ genLit = \case
| otherwise -> return [ toJExpr (global (mkRawSymbol True name))
, ValExpr (JInt 0)
]
- LitRubbish {} -> return [ null_ ]
+ LitRubbish _ rr_ty ->
+ -- Generate appropriate rubbish literals, otherwise it might trip up the
+ -- code generator when a primop is applied to a rubbish literal (see #24664)
+ let reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genLit") rr_ty
+ rub = \case
+ BoxedRep _ -> [ null_ ]
+ AddrRep -> [ null_, ValExpr (JInt 0) ]
+ WordRep -> [ ValExpr (JInt 0) ]
+ Word8Rep -> [ ValExpr (JInt 0) ]
+ Word16Rep -> [ ValExpr (JInt 0) ]
+ Word32Rep -> [ ValExpr (JInt 0) ]
+ Word64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ]
+ IntRep -> [ ValExpr (JInt 0) ]
+ Int8Rep -> [ ValExpr (JInt 0) ]
+ Int16Rep -> [ ValExpr (JInt 0) ]
+ Int32Rep -> [ ValExpr (JInt 0) ]
+ Int64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ]
+ DoubleRep -> [ ValExpr (JInt 0) ]
+ FloatRep -> [ ValExpr (JInt 0) ]
+ VecRep _ _ -> panic "GHC.StgToJS.Literal.genLit: VecRep unsupported"
+ in return (concatMap rub reps)
-- | generate a literal for the static init tables
genStaticLit :: Literal -> G [StaticLit]
=====================================
configure.ac
=====================================
@@ -740,10 +740,6 @@ dnl ** check for tar
dnl if GNU tar is named gtar, look for it first.
AC_PATH_PROGS(TarCmd,gnutar gtar tar,tar)
-dnl ** check for patch
-dnl if GNU patch is named gpatch, look for it first
-AC_PATH_PROGS(PatchCmd,gpatch patch, patch)
-
dnl ** check for autoreconf
AC_PATH_PROG(AutoreconfCmd, autoreconf, autoreconf)
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -17,7 +17,6 @@ sphinx-build = @SPHINXBUILD@
system-ghc = @WithGhc@
system-ghc-pkg = @GhcPkgCmd@
tar = @TarCmd@
-patch = @PatchCmd@
xelatex = @XELATEX@
makeindex = @MAKEINDEX@
makeinfo = @MAKEINFO@
=====================================
hadrian/src/Builder.hs
=====================================
@@ -8,10 +8,7 @@ module Builder (
-- * Builder properties
builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilders,
runBuilder, runBuilderWith, runBuilderWithCmdOptions, getBuilderPath,
- builderEnvironment,
-
- -- * Ad hoc builder invocation
- applyPatch
+ builderEnvironment
) where
import Control.Exception.Extra (Partial)
@@ -184,7 +181,6 @@ data Builder = Alex
| MergeObjects Stage -- ^ linker to be used to merge object files.
| Nm
| Objdump
- | Patch
| Python
| Ranlib
| Testsuite TestMode
@@ -443,7 +439,6 @@ systemBuilderPath builder = case builder of
Makeinfo -> fromKey "makeinfo"
Nm -> fromTargetTC "nm" (Toolchain.nmProgram . tgtNm)
Objdump -> fromKey "objdump"
- Patch -> fromKey "patch"
Python -> fromKey "python"
Ranlib -> fromTargetTC "ranlib" (maybeProg Toolchain.ranlibProgram . tgtRanlib)
Testsuite _ -> fromKey "python"
@@ -511,15 +506,6 @@ systemBuilderPath builder = case builder of
isSpecified :: Builder -> Action Bool
isSpecified = fmap (not . null) . systemBuilderPath
--- | Apply a patch by executing the 'Patch' builder in a given directory.
-applyPatch :: FilePath -> FilePath -> Action ()
-applyPatch dir patch = do
- let file = dir -/- patch
- needBuilders [Patch]
- path <- builderPath Patch
- putBuild $ "| Apply patch " ++ file
- quietly $ cmd' [Cwd dir, FileStdin file] [path, "-p0"]
-
-- Note [cmd wrapper]
-- ~~~~~~~~~~~~~~~~~~
-- `cmd'` is a wrapper for Shake's `cmd` that allows us to customize what is
=====================================
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
=====================================
hadrian/src/Rules/Gmp.hs
=====================================
@@ -143,23 +143,18 @@ gmpRules = do
gmpP = takeDirectory gmpBuildP
ctx <- makeGmpPathContext gmpP
removeDirectory gmpBuildP
- -- Note: We use a tarball like gmp-4.2.4-nodoc.tar.bz2, which is
- -- gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents.
+ -- Note: We use a tarball like gmp-4.2.4-nodoc.tar.xz, which is
+ -- gmp-4.2.4.tar.xz repacked without the doc/ directory contents.
-- That's because the doc/ directory contents are under the GFDL,
-- which causes problems for Debian.
tarball <- unifyPath . fromSingleton "Exactly one GMP tarball is expected"
- <$> getDirectoryFiles top [gmpBase -/- "gmp-tarballs/gmp*.tar.bz2"]
+ <$> getDirectoryFiles top [gmpBase -/- "gmp-tarballs/gmp*.tar.xz"]
withTempDir $ \dir -> do
let tmp = unifyPath dir
need [top -/- tarball]
build $ target ctx (Tar Extract) [top -/- tarball] [tmp]
- let patch = gmpBase -/- "gmpsrc.patch"
- patchName = takeFileName patch
- copyFile patch $ tmp -/- patchName
- applyPatch tmp patchName
-
let name = dropExtension . dropExtension $ takeFileName tarball
unpack = fromMaybe . error $ "gmpRules: expected suffix "
++ "-nodoc (found: " ++ name ++ ")."
=====================================
libraries/ghc-bignum/gmp/gmp-tarballs
=====================================
@@ -1 +1 @@
-Subproject commit 4f26049af40afb380eaf033ab91404cd2e214919
+Subproject commit 01149ce3471128e9fe0feca607579981f4b64395
=====================================
libraries/ghc-bignum/gmp/gmpsrc.patch deleted
=====================================
@@ -1,44 +0,0 @@
-diff -Naur gmp-6.2.1/Makefile.am gmpbuild/Makefile.am
---- gmp-6.2.1/Makefile.am 2020-11-15 02:45:09.000000000 +0800
-+++ gmpbuild/Makefile.am 2021-01-09 22:56:14.571708858 +0800
-@@ -112,7 +112,7 @@
- LIBGMPXX_LT_AGE = 6
-
-
--SUBDIRS = tests mpn mpz mpq mpf printf scanf rand cxx demos tune doc
-+SUBDIRS = tests mpn mpz mpq mpf printf scanf rand cxx demos tune
-
- EXTRA_DIST = configfsf.guess configfsf.sub .gdbinit INSTALL.autoconf \
- COPYING.LESSERv3 COPYINGv2 COPYINGv3
-diff -Naur gmp-6.2.1/Makefile.in gmpbuild/Makefile.in
---- gmp-6.2.1/Makefile.in 2020-11-15 02:45:16.000000000 +0800
-+++ gmpbuild/Makefile.in 2021-01-10 16:15:37.387670402 +0800
-@@ -572,7 +572,7 @@
- LIBGMPXX_LT_CURRENT = 10
- LIBGMPXX_LT_REVISION = 1
- LIBGMPXX_LT_AGE = 6
--SUBDIRS = tests mpn mpz mpq mpf printf scanf rand cxx demos tune doc
-+SUBDIRS = tests mpn mpz mpq mpf printf scanf rand cxx demos tune
-
- # Put asl.h here for now.
-
-diff -Naur gmp-6.2.1/configure gmpbuild/configure
---- gmp-6.2.1/configure 2020-11-15 02:45:15.000000000 +0800
-+++ gmpbuild/configure 2021-01-10 16:13:59.196004951 +0800
-@@ -27985,7 +27985,7 @@
- # FIXME: Upcoming version of autoconf/automake may not like broken lines.
- # Right now automake isn't accepting the new AC_CONFIG_FILES scheme.
-
--ac_config_files="$ac_config_files Makefile mpf/Makefile mpn/Makefile mpq/Makefile mpz/Makefile printf/Makefile scanf/Makefile rand/Makefile cxx/Makefile tests/Makefile tests/devel/Makefile tests/mpf/Makefile tests/mpn/Makefile tests/mpq/Makefile tests/mpz/Makefile tests/rand/Makefile tests/misc/Makefile tests/cxx/Makefile doc/Makefile tune/Makefile demos/Makefile demos/calc/Makefile demos/expr/Makefile gmp.h:gmp-h.in gmp.pc:gmp.pc.in gmpxx.pc:gmpxx.pc.in"
-+ac_config_files="$ac_config_files Makefile mpf/Makefile mpn/Makefile mpq/Makefile mpz/Makefile printf/Makefile scanf/Makefile rand/Makefile cxx/Makefile tests/Makefile tests/devel/Makefile tests/mpf/Makefile tests/mpn/Makefile tests/mpq/Makefile tests/mpz/Makefile tests/rand/Makefile tests/misc/Makefile tests/cxx/Makefile tune/Makefile demos/Makefile demos/calc/Makefile demos/expr/Makefile gmp.h:gmp-h.in gmp.pc:gmp.pc.in gmpxx.pc:gmpxx.pc.in"
-
- cat >confcache <<\_ACEOF
- # This file is a shell script that caches the results of configure
-@@ -29129,7 +29129,6 @@
- "tests/rand/Makefile") CONFIG_FILES="$CONFIG_FILES tests/rand/Makefile" ;;
- "tests/misc/Makefile") CONFIG_FILES="$CONFIG_FILES tests/misc/Makefile" ;;
- "tests/cxx/Makefile") CONFIG_FILES="$CONFIG_FILES tests/cxx/Makefile" ;;
-- "doc/Makefile") CONFIG_FILES="$CONFIG_FILES doc/Makefile" ;;
- "tune/Makefile") CONFIG_FILES="$CONFIG_FILES tune/Makefile" ;;
- "demos/Makefile") CONFIG_FILES="$CONFIG_FILES demos/Makefile" ;;
- "demos/calc/Makefile") CONFIG_FILES="$CONFIG_FILES demos/calc/Makefile" ;;
=====================================
libraries/ghc-bignum/gmp/ln deleted
=====================================
@@ -1,3 +0,0 @@
-#!/bin/sh
-exit 1
-
=====================================
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/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/e77abdd6af72be43d398826e472a2386d141af13...3e65cec94a0536720fe70dc734db10c6dac9ada3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e77abdd6af72be43d398826e472a2386d141af13...3e65cec94a0536720fe70dc734db10c6dac9ada3
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/c3d392e6/attachment-0001.html>
More information about the ghc-commits
mailing list