[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Oct 19 13:17:24 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
fe067577 by Sylvain Henry at 2023-10-18T19:40:25-04:00
Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066)
bigNatIndex# in the `where` clause wasn't guarded by "bigNatIsZero a".
- - - - -
cc1625b1 by Sylvain Henry at 2023-10-18T19:40:25-04:00
Bignum: fix right shift of negative BigNat with native backend
- - - - -
cbe4400d by Sylvain Henry at 2023-10-18T19:40:25-04:00
Rts: expose rtsOutOfBoundsAccess symbol
- - - - -
72c7380c by Sylvain Henry at 2023-10-18T19:40:25-04:00
Hadrian: enable `-fcheck-prim-bounds` in validate flavour
This allows T24066 to fail when the bug is present.
Otherwise the out-of-bound access isn't detected as it happens in
ghc-bignum which wasn't compiled with the bounds check.
- - - - -
f9436990 by John Ericson at 2023-10-18T19:41:01-04:00
Make Hadrian solely responsible for substituting `docs/users_guide/ghc_config.py.in`
Fixes #24091
Progress on #23966
Issue #24091 reports that `@ProjectVersion@` is no longer being
substituted in the GHC user's guide. I assume this is a recent issue,
but I am not sure how it's worked since
c1a3ecde720b3bddc2c8616daaa06ee324e602ab; it looks like both Hadrian and
configure are trying to substitute the same `.in` file!
Now only Hadrian does. That is better anyways; already something that
issue #23966 requested.
It seems like we were missing some dependencies in Hadrian. (I really,
really hate that this is possible!) Hopefully it is fixed now.
- - - - -
b12df0bb by John Ericson at 2023-10-18T19:41:37-04:00
`ghcversion.h`: No need to cope with undefined `ProjectPatchLevel*`
Since 4e6c80197f1cc46dfdef0300de46847c7cfbdcb0, these are guaranteed to
be defined. (Guaranteed including a test in the testsuite.)
- - - - -
0295375a by John Ericson at 2023-10-18T19:41:37-04:00
Generate `ghcversion.h` from a `.in` file
Now that there are no conditional sections (see the previous commit), we
can just a do simple substitution rather than pasting it together line
by line.
Progress on #23966
- - - - -
8984c6da by Krzysztof Gogolewski at 2023-10-19T09:17:10-04:00
Add a regression test for #24064
- - - - -
61ef0112 by Hécate Moonlight at 2023-10-19T09:17:14-04:00
CLC Proposal #182: Export List from Data.List
Proposal link: https://github.com/haskell/core-libraries-committee/issues/182
- - - - -
28 changed files:
- configure.ac
- hadrian/cfg/system.config.in
- hadrian/doc/flavours.md
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Builders/Cabal.hs
- hadrian/src/Settings/Flavours/Validate.hs
- libraries/base/changelog.md
- libraries/base/src/Data/List.hs
- libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs
- libraries/ghc-bignum/src/GHC/Num/BigNat.hs
- libraries/ghc-prim/GHC/Types.hs
- rts/RtsMessages.c
- rts/RtsSymbols.c
- − rts/ghcversion.h.top
- rts/ghcversion.h.bottom → rts/include/ghcversion.h.in
- rts/include/rts/Messages.h
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + testsuite/tests/numeric/should_run/T24066.hs
- + testsuite/tests/numeric/should_run/T24066.stdout
- testsuite/tests/numeric/should_run/all.T
- + testsuite/tests/typecheck/should_fail/T24064.hs
- + testsuite/tests/typecheck/should_fail/T24064.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
configure.ac
=====================================
@@ -68,23 +68,6 @@ FP_PROG_SORT
dnl ----------------------------------------------------------
FP_SETUP_PROJECT_VERSION
-dnl Don't use AC_DEFINE because it will make C-style comments invalid for
-dnl Haskell.
-
-> rts/include/ghcversion.h
-
-cat rts/ghcversion.h.top >> rts/include/ghcversion.h
-
-echo "#define __GLASGOW_HASKELL__ ${ProjectVersionInt}" >> rts/include/ghcversion.h
-echo "#define __GLASGOW_HASKELL_FULL_VERSION__ \"${ProjectVersion}\"" >> rts/include/ghcversion.h
-echo >> rts/include/ghcversion.h
-AS_IF([test x"${ProjectPatchLevel1}" != x],
- [echo "#define __GLASGOW_HASKELL_PATCHLEVEL1__ ${ProjectPatchLevel1}" >> rts/include/ghcversion.h])
-AS_IF([test x"${ProjectPatchLevel2}" != x],
- [echo "#define __GLASGOW_HASKELL_PATCHLEVEL2__ ${ProjectPatchLevel2}" >> rts/include/ghcversion.h])
-
-cat rts/ghcversion.h.bottom >> rts/include/ghcversion.h
-
# Hmmm, we fix the RPM release number to 1 here... Is this convenient?
AC_SUBST([release], [1])
@@ -105,8 +88,6 @@ AC_PREREQ([2.69])
AC_CONFIG_HEADER(mk/config.h)
# This one is manually maintained.
AC_CONFIG_HEADER(compiler/ghc-llvm-version.h)
-dnl manually outputted above, for reasons described there.
-dnl AC_CONFIG_HEADER(rts/include/ghcversion.h)
# No, semi-sadly, we don't do `--srcdir'...
if test x"$srcdir" != 'x.' ; then
@@ -1069,7 +1050,6 @@ AC_CONFIG_FILES(
hadrian/ghci-cabal
hadrian/ghci-multi-cabal
hadrian/ghci-stack
- docs/users_guide/ghc_config.py
distrib/configure.ac
hadrian/cfg/default.host.target
hadrian/cfg/default.target
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -34,6 +34,9 @@ python = @PythonCmd@
cc-llvm-backend = @CcLlvmBackend@
+llvm-min-version = @LlvmMinVersion@
+llvm-max-version = @LlvmMaxVersion@
+
# Build options:
#===============
=====================================
hadrian/doc/flavours.md
=====================================
@@ -157,7 +157,7 @@ when compiling the `compiler` library, and `hsGhc` when compiling/linking the GH
<th>validate</td>
<td></td>
<td>-O0<br>-H64m</td>
- <td>-fllvm-fill-undef-with-garbage</td>
+ <td>-fllvm-fill-undef-with-garbage<br>-fcheck-prim-bounds</td>
<td></td>
<td>-O<br>-dcore-lint<br>-dno-debug-output</td>
<td>-O2<br>-DDEBUG</td>
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -49,6 +49,8 @@ data Setting = CursesIncludeDir
| GhcPatchLevel
| GhcVersion
| GhcSourcePath
+ | LlvmMinVersion
+ | LlvmMaxVersion
| GmpIncludeDir
| GmpLibDir
| IconvIncludeDir
@@ -103,6 +105,8 @@ setting key = lookupSystemConfig $ case key of
GhcPatchLevel -> "ghc-patch-level"
GhcVersion -> "ghc-version"
GhcSourcePath -> "ghc-source-path"
+ LlvmMinVersion -> "llvm-min-version"
+ LlvmMaxVersion -> "llvm-max-version"
GmpIncludeDir -> "gmp-include-dir"
GmpLibDir -> "gmp-lib-dir"
IconvIncludeDir -> "iconv-include-dir"
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -356,6 +356,9 @@ buildSphinxInfoGuide = do
root <- buildRootRules
let path = "GHCUsersGuide"
root -/- infoRoot -/- path <.> "info" %> \ file -> do
+
+ needDocDeps
+
withTempDir $ \dir -> do
let rstFilesDir = pathPath path
rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
@@ -391,6 +394,8 @@ buildManPage = do
root <- buildRootRules
root -/- manPageBuildPath %> \file -> do
need ["docs/users_guide/ghc.rst"]
+ needDocDeps
+
withTempDir $ \dir -> do
build $ target docContext (Sphinx ManMode) ["docs/users_guide"] [dir]
checkSphinxWarnings dir
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -323,8 +323,19 @@ templateRules = do
templateRule "utils/ghc-pkg/ghc-pkg.cabal" $ projectVersion
templateRule "libraries/template-haskell/template-haskell.cabal" $ projectVersion
templateRule "libraries/prologue.txt" $ packageVersions
+ templateRule "rts/include/ghcversion.h" $ mconcat
+ [ interpolateSetting "ProjectVersionInt" ProjectVersionInt
+ , interpolateSetting "ProjectVersion" ProjectVersion
+ , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1
+ , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2
+ ]
templateRule "docs/index.html" $ packageVersions
- templateRule "docs/users_guide/ghc_config.py" $ packageUnitIds Stage1
+ templateRule "docs/users_guide/ghc_config.py" $ mconcat
+ [ projectVersion
+ , packageUnitIds Stage1
+ , interpolateSetting "LlvmMinVersion" LlvmMinVersion
+ , interpolateSetting "LlvmMaxVersion" LlvmMaxVersion
+ ]
-- Generators
=====================================
hadrian/src/Settings/Builders/Cabal.hs
=====================================
@@ -166,9 +166,14 @@ configureStageArgs = do
let cFlags = getStagedCCFlags
linkFlags = prgFlags . ccLinkProgram . tgtCCompilerLink <$> getStagedTarget
mconcat [ configureArgs cFlags linkFlags
- , notStage0 ? arg "--ghc-option=-ghcversion-file=rts/include/ghcversion.h"
+ , ghcVersionH
]
+ghcVersionH :: Args
+ghcVersionH = notStage0 ? do
+ let h = "rts/include/ghcversion.h"
+ expr $ need [h]
+ arg $ "--ghc-option=-ghcversion-file=" <> h
configureArgs :: Args -> Args -> Args
configureArgs cFlags' ldFlags' = do
@@ -199,7 +204,7 @@ configureArgs cFlags' ldFlags' = do
-- ROMES:TODO: how is the Host set to TargetPlatformFull? That would be the target
, conf "--host" $ arg =<< getSetting TargetPlatformFull
, conf "--with-cc" $ arg =<< getBuilderPath . (Cc CompileC) =<< getStage
- , notStage0 ? arg "--ghc-option=-ghcversion-file=rts/include/ghcversion.h"
+ , ghcVersionH
]
bootPackageConstraints :: Args
=====================================
hadrian/src/Settings/Flavours/Validate.hs
=====================================
@@ -35,6 +35,7 @@ validateArgs = sourceArgs SourceArgs
-- See #11487
, notStage0 ? arg "-fllvm-fill-undef-with-garbage"
, notStage0 ? arg "-dno-debug-output"
+ , notStage0 ? arg "-fcheck-prim-bounds"
]
, hsLibrary = pure ["-O"]
, hsCompiler = mconcat [ stage0 ? pure ["-O2"]
=====================================
libraries/base/changelog.md
=====================================
@@ -8,6 +8,7 @@
* Fix `fdIsNonBlocking` to always be `0` for regular files and block devices on unix, regardless of `O_NONBLOCK`
* Always use `safe` call to `read` for regular files and block devices on unix if the RTS is multi-threaded, regardless of `O_NONBLOCK`.
([CLC proposal #166](https://github.com/haskell/core-libraries-committee/issues/166))
+ * Export List from Data.List ([CLC proposal #182](https://github.com/haskell/core-libraries-committee/issues/182)).
## 4.19.0.0 *TBA*
* Add `{-# WARNING in "x-partial" #-}` to `Data.List.{head,tail}`.
=====================================
libraries/base/src/Data/List.hs
=====================================
@@ -17,9 +17,10 @@
module Data.List
(
+ List
-- * Basic functions
- (++)
+ , (++)
, head
, last
, tail
@@ -222,6 +223,7 @@ import Data.OldList hiding ( all, and, any, concat, concatMap, elem, find,
length, notElem, null, or, product, sum )
import GHC.Base ( Bool(..), Eq((==)), otherwise )
+import GHC.List (List)
-- | The 'isSubsequenceOf' function takes two lists and returns 'True' if all
-- the elements of the first list occur, in order, in the second. The
=====================================
libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs
=====================================
@@ -295,15 +295,15 @@ bignat_shiftr_neg
-> State# s
-> State# s
bignat_shiftr_neg mwa wa n s1
- -- initialize higher limb
- = case mwaWrite# mwa (szA -# 1#) 0## s1 of
- s2 -> case bignat_shiftr mwa wa n s2 of
- s3 -> if nz_shifted_out
- -- round if non-zero bits were shifted out
- then mwaAddInplaceWord# mwa 0# 1## s3
- else s3
+ -- initialize higher limb of mwa
+ = case mwaSize# mwa s1 of
+ (# s2, sz_mwa #) -> case mwaWrite# mwa (sz_mwa -# 1#) 0## s2 of
+ s3 -> case bignat_shiftr mwa wa n s3 of
+ s4 -> if nz_shifted_out
+ -- round if non-zero bits were shifted out
+ then mwaAddInplaceWord# mwa 0# 1## s4
+ else s4
where
- !szA = wordArraySize# wa
!(# nw, nb #) = count_words_bits_int n
-- non-zero bits are shifted out?
=====================================
libraries/ghc-bignum/src/GHC/Num/BigNat.hs
=====================================
@@ -135,13 +135,8 @@ bigNatIsTwo# ba =
bigNatIsPowerOf2# :: BigNat# -> (# (# #) | Word# #)
bigNatIsPowerOf2# a
| bigNatIsZero a = (# (# #) | #)
- | True = case wordIsPowerOf2# msw of
- (# (# #) | #) -> (# (# #) | #)
- (# | c #) -> case checkAllZeroes (imax -# 1#) of
- 0# -> (# (# #) | #)
- _ -> (# | c `plusWord#`
- (int2Word# imax `uncheckedShiftL#` WORD_SIZE_BITS_SHIFT#) #)
- where
+ | True =
+ let
msw = bigNatIndex# a imax
sz = bigNatSize# a
imax = sz -# 1#
@@ -150,6 +145,12 @@ bigNatIsPowerOf2# a
| True = case bigNatIndex# a i of
0## -> checkAllZeroes (i -# 1#)
_ -> 0#
+ in case wordIsPowerOf2# msw of
+ (# (# #) | #) -> (# (# #) | #)
+ (# | c #) -> case checkAllZeroes (imax -# 1#) of
+ 0# -> (# (# #) | #)
+ _ -> (# | c `plusWord#`
+ (int2Word# imax `uncheckedShiftL#` WORD_SIZE_BITS_SHIFT#) #)
-- | Return the Word# at the given index
bigNatIndex# :: BigNat# -> Int# -> Word#
=====================================
libraries/ghc-prim/GHC/Types.hs
=====================================
@@ -168,15 +168,27 @@ type family Any :: k where { }
* *
********************************************************************* -}
--- | The builtin list type, usually written in its non-prefix form @[a]@.
+-- | The builtin linked list type.
--
-- In Haskell, lists are one of the most important data types as they are
-- often used analogous to loops in imperative programming languages.
--- These lists are singly linked, which makes it unsuited for operations
--- that require \(\mathcal{O}(1)\) access. Instead, lists are intended to
+-- These lists are singly linked, which makes them unsuited for operations
+-- that require \(\mathcal{O}(1)\) access. Instead, they are intended to
-- be traversed.
--
--- Lists are constructed recursively using the right-associative cons-operator
+-- You can use @List a@ or @[a]@ in type signatures:
+--
+-- > length :: [a] -> Int
+--
+-- or
+--
+-- > length :: List a -> Int
+--
+-- They are fully equivalent, and @List a@ will be normalised to @[a]@.
+--
+-- ==== Usage
+--
+-- Lists are constructed recursively using the right-associative constructor operator (or /cons/)
-- @(:) :: a -> [a] -> [a]@, which prepends an element to a list,
-- and the empty list @[]@.
--
@@ -184,6 +196,16 @@ type family Any :: k where { }
-- (1 : 2 : 3 : []) == (1 : (2 : (3 : []))) == [1, 2, 3]
-- @
--
+-- Lists can also be constructed using list literals
+-- of the form @[x_1, x_2, ..., x_n]@
+-- which are syntactic sugar and, unless @-XOverloadedLists@ is enabled,
+-- are translated into uses of @(:)@ and @[]@
+--
+-- 'Data.String.String' literals, like @"I 💜 hs"@, are translated into
+-- Lists of characters, @[\'I\', \' \', \'💜\', \' \', \'h\', \'s\']@.
+--
+-- ==== __Implementation__
+--
-- Internally and in memory, all the above are represented like this,
-- with arrows being pointers to locations in memory.
--
@@ -193,14 +215,6 @@ type family Any :: k where { }
-- > v v v
-- > 1 2 3
--
--- As seen above, lists can also be constructed using list literals
--- of the form @[x_1, x_2, ..., x_n]@
--- which are syntactic sugar and, unless @-XOverloadedLists@ is enabled,
--- are translated into uses of @(:)@ and @[]@
---
--- Similarly, 'Data.String.String' literals of the form @"I 💜 hs"@ are translated into
--- Lists of characters, @[\'I\', \' \', \'💜\', \' \', \'h\', \'s\']@.
---
-- ==== __Examples__
--
-- @
=====================================
rts/RtsMessages.c
=====================================
@@ -326,27 +326,18 @@ rtsDebugMsgFn(const char *s, va_list ap)
}
-// Used in stg_badAlignment_entry defined in StgStartup.cmm.
-void rtsBadAlignmentBarf(void) STG_NORETURN;
-
void
rtsBadAlignmentBarf(void)
{
barf("Encountered incorrectly aligned pointer. This can't be good.");
}
-// Used by code generator
-void rtsOutOfBoundsAccess(void) STG_NORETURN;
-
void
rtsOutOfBoundsAccess(void)
{
barf("Encountered out of bounds array access.");
}
-// Used by code generator
-void rtsMemcpyRangeOverlap(void) STG_NORETURN;
-
void
rtsMemcpyRangeOverlap(void)
{
=====================================
rts/RtsSymbols.c
=====================================
@@ -947,6 +947,9 @@ extern char **environ;
SymI_HasProto(arenaFree) \
SymI_HasProto(rts_clearMemory) \
SymI_HasProto(setKeepCAFs) \
+ SymI_HasProto(rtsBadAlignmentBarf) \
+ SymI_HasProto(rtsOutOfBoundsAccess) \
+ SymI_HasProto(rtsMemcpyRangeOverlap) \
RTS_USER_SIGNALS_SYMBOLS \
RTS_INTCHAR_SYMBOLS
=====================================
rts/ghcversion.h.top deleted
=====================================
@@ -1,3 +0,0 @@
-#if !defined(__GHCVERSION_H__)
-#define __GHCVERSION_H__
-
=====================================
rts/ghcversion.h.bottom → rts/include/ghcversion.h.in
=====================================
@@ -1,3 +1,11 @@
+#if !defined(__GHCVERSION_H__)
+#define __GHCVERSION_H__
+
+#define __GLASGOW_HASKELL__ @ProjectVersionInt@
+#define __GLASGOW_HASKELL_FULL_VERSION__ "@ProjectVersion@"
+
+#define __GLASGOW_HASKELL_PATCHLEVEL1__ @ProjectPatchLevel1@
+#define __GLASGOW_HASKELL_PATCHLEVEL2__ @ProjectPatchLevel2@
#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) ( \
((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
=====================================
rts/include/rts/Messages.h
=====================================
@@ -78,7 +78,6 @@ void debugBelch(const char *s, ...)
int vdebugBelch(const char *s, va_list ap);
-
/* Hooks for redirecting message generation: */
typedef void RtsMsgFunction(const char *, va_list);
@@ -94,3 +93,8 @@ extern RtsMsgFunction rtsFatalInternalErrorFn;
extern RtsMsgFunctionRetLen rtsDebugMsgFn;
extern RtsMsgFunction rtsErrorMsgFn;
extern RtsMsgFunction rtsSysErrorMsgFn;
+
+/* Used by code generator */
+void rtsBadAlignmentBarf(void) STG_NORETURN;
+void rtsOutOfBoundsAccess(void) STG_NORETURN;
+void rtsMemcpyRangeOverlap(void) STG_NORETURN;
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1252,6 +1252,8 @@ module Data.List where
(!!) :: forall a. GHC.Stack.Types.HasCallStack => [a] -> GHC.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Types.Int -> GHC.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
+ type List :: * -> *
+ data List a = ...
(\\) :: forall a. GHC.Classes.Eq a => [a] -> [a] -> [a]
all :: forall (t :: * -> *) a. Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
and :: forall (t :: * -> *). Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1252,6 +1252,8 @@ module Data.List where
(!!) :: forall a. GHC.Stack.Types.HasCallStack => [a] -> GHC.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Types.Int -> GHC.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
+ type List :: * -> *
+ data List a = ...
(\\) :: forall a. GHC.Classes.Eq a => [a] -> [a] -> [a]
all :: forall (t :: * -> *) a. Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
and :: forall (t :: * -> *). Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1252,6 +1252,8 @@ module Data.List where
(!!) :: forall a. GHC.Stack.Types.HasCallStack => [a] -> GHC.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Types.Int -> GHC.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
+ type List :: * -> *
+ data List a = ...
(\\) :: forall a. GHC.Classes.Eq a => [a] -> [a] -> [a]
all :: forall (t :: * -> *) a. Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
and :: forall (t :: * -> *). Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -1252,6 +1252,8 @@ module Data.List where
(!!) :: forall a. GHC.Stack.Types.HasCallStack => [a] -> GHC.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Types.Int -> GHC.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
+ type List :: * -> *
+ data List a = ...
(\\) :: forall a. GHC.Classes.Eq a => [a] -> [a] -> [a]
all :: forall (t :: * -> *) a. Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
and :: forall (t :: * -> *). Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/numeric/should_run/T24066.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+import GHC.Num.BigNat
+import GHC.Exts
+
+-- just to ensure that (future) rewrite rules don't mess with the test
+{-# NOINLINE foo #-}
+foo (# #) = bigNatZero# (# #)
+
+main = do
+ case bigNatIsPowerOf2# (foo (# #)) of
+ (# _ | #) -> putStrLn "Zero isn't a power of two"
+ (# | w #) -> putStrLn $ "Zero is 2^" ++ show (W# w)
=====================================
testsuite/tests/numeric/should_run/T24066.stdout
=====================================
@@ -0,0 +1 @@
+Zero isn't a power of two
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -81,3 +81,4 @@ test('T20291', normal, compile_and_run, [''])
test('T22282', normal, compile_and_run, [''])
test('T22671', normal, compile_and_run, [''])
test('foundation', [when(js_arch(), run_timeout_multiplier(2))], compile_and_run, ['-O -package transformers'])
+test('T24066', normal, compile_and_run, [''])
=====================================
testsuite/tests/typecheck/should_fail/T24064.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T24064 where
+
+class C1 b where
+ type F1 b
+
+class C2 (m :: * -> *) where
+ type F2 m
+
+class C3 r where
+ type F3 r
+
+class G t m where
+ g :: m a -> t m a
+
+data Y
+
+data X e a
+
+data H a
+
+data S a
+
+fun1 :: X e ()
+fun1 = undefined
+
+fun2 :: S ()
+fun2 = undefined
+
+fun3 :: H ()
+fun3 = undefined
+
+fun4 :: (F3 r ~ F1 (F2 m)) => r -> m ()
+fun4 = undefined
+
+test :: (C2 m, F2 m ~ Y) => m ()
+test = do
+ fun1
+ fun2
+ g fun3
+ fun4 undefined
+
+main :: IO ()
+main = pure ()
=====================================
testsuite/tests/typecheck/should_fail/T24064.stderr
=====================================
@@ -0,0 +1,26 @@
+
+T24064.hs:42:3: error: [GHC-25897]
+ • Could not deduce ‘m ~ X e0’
+ from the context: (C2 m, F2 m ~ Y)
+ bound by the type signature for:
+ test :: forall (m :: * -> *). (C2 m, F2 m ~ Y) => m ()
+ at T24064.hs:40:1-32
+ Expected: m ()
+ Actual: X e0 ()
+ ‘m’ is a rigid type variable bound by
+ the type signature for:
+ test :: forall (m :: * -> *). (C2 m, F2 m ~ Y) => m ()
+ at T24064.hs:40:1-32
+ • In a stmt of a 'do' block: fun1
+ In the expression:
+ do fun1
+ fun2
+ g fun3
+ fun4 undefined
+ In an equation for ‘test’:
+ test
+ = do fun1
+ fun2
+ g fun3
+ ....
+ • Relevant bindings include test :: m () (bound at T24064.hs:41:1)
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -704,3 +704,4 @@ test('T22478c', normal, compile_fail, [''])
test('T23776', normal, compile, ['']) # to become an error in GHC 9.12
test('T17940', normal, compile_fail, [''])
test('ErrorIndexLinks', normal, compile_fail, ['-fprint-error-index-links=always'])
+test('T24064', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6771670d48ff88910c53eea6c38dda469c672c9a...61ef011200275ed2d3bf3e3fc02dde253f0e3fe2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6771670d48ff88910c53eea6c38dda469c672c9a...61ef011200275ed2d3bf3e3fc02dde253f0e3fe2
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/20231019/1c225b58/attachment-0001.html>
More information about the ghc-commits
mailing list