[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: genSym: Reimplement via CAS on 32-bit platforms
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Dec 29 17:46:01 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
c873f767 by Ben Gamari at 2023-12-29T12:45:38-05:00
genSym: Reimplement via CAS on 32-bit platforms
Previously the remaining use of the C implementation on 32-bit platforms
resulted in a subtle bug, #24261. This was due to the C object (which
used the RTS's `atomic_inc64` macro) being compiled without `-threaded`
yet later being used in a threaded compiler.
Side-step this issue by using the pure Haskell `genSym` implementation on
all platforms. This required implementing `fetchAddWord64Addr#` in terms
of CAS on 64-bit platforms.
- - - - -
b3162c7c by Xiaoyan Ren at 2023-12-29T12:45:41-05:00
Do not color the diagnostic code in error messages (#24172)
- - - - -
1640940f by Krzysztof Gogolewski at 2023-12-29T12:45:42-05:00
Enforce that bindings of implicit parameters are lifted
Fixes #24298
- - - - -
12 changed files:
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Unique/Supply.hs
- compiler/cbits/genSym.c
- compiler/jsbits/genSym.js
- + testsuite/tests/ghc-e/should_fail/T24172.hs
- + testsuite/tests/ghc-e/should_fail/T24172.stderr
- testsuite/tests/ghc-e/should_fail/all.T
- + testsuite/tests/typecheck/should_fail/T24298.hs
- + testsuite/tests/typecheck/should_fail/T24298.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/warnings/should_fail/Colour.stderr
Changes:
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -291,7 +291,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
-- ?y = ?x + 1
tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc)
tc_ip_bind ipClass (IPBind _ l_name@(L _ ip) expr)
- = do { ty <- newOpenFlexiTyVarTy
+ = do { ty <- newFlexiTyVarTy liftedTypeKind -- see #24298
; let p = mkStrLitTy $ hsIPNameFS ip
; ip_id <- newDict ipClass [ p, ty ]
; expr' <- tcCheckMonoExpr expr ty
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -659,7 +659,7 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
code_doc =
case msg_class of
- MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr_with_hyperlink code)
+ MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code)
_ -> empty
flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -45,15 +45,20 @@ import Foreign.Storable
#include "MachDeps.h"
-#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) && WORD_SIZE_IN_BITS == 64
-import GHC.Word( Word64(..) )
-import GHC.Exts( fetchAddWordAddr#, plusWord#, readWordOffAddr# )
-#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
-import GHC.Exts( wordToWord64# )
+#if WORD_SIZE_IN_BITS != 64
+#define NO_FETCH_ADD
#endif
+
+#if defined(NO_FETCH_ADD)
+import GHC.Exts ( atomicCasWord64Addr#, eqWord64# )
+#else
+import GHC.Exts( fetchAddWordAddr#, word64ToWord#, wordToWord64# )
#endif
-#include "Unique.h"
+import GHC.Exts ( Addr#, State#, Word64#, RealWorld )
+
+import GHC.Word( Word64(..) )
+import GHC.Exts( plusWord64#, readWord64OffAddr# )
{-
************************************************************************
@@ -228,25 +233,37 @@ mkSplitUniqSupply c
(# s4, MkSplitUniqSupply (tag .|. u) x y #)
}}}}
--- If a word is not 64 bits then we would need a fetchAddWord64Addr# primitive,
--- which does not exist. So we fall back on the C implementation in that case.
-
-#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) || WORD_SIZE_IN_BITS != 64
-foreign import ccall unsafe "genSym" genSym :: IO Word64
+#if defined(NO_FETCH_ADD)
+-- GHC currently does not provide this operation on 32-bit platforms,
+-- hence the CAS-based implementation.
+fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld
+ -> (# State# RealWorld, Word64# #)
+fetchAddWord64Addr# = go
+ where
+ go ptr inc s0 =
+ case readWord64OffAddr# ptr 0# s0 of
+ (# s1, n0 #) ->
+ case atomicCasWord64Addr# ptr n0 (n0 `plusWord64#` inc) s1 of
+ (# s2, res #)
+ | 1# <- res `eqWord64#` n0 -> (# s2, n0 #)
+ | otherwise -> go ptr inc s2
#else
+fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld
+ -> (# State# RealWorld, Word64# #)
+fetchAddWord64Addr# addr inc s0 =
+ case fetchAddWordAddr# addr (word64ToWord# inc) s0 of
+ (# s1, res #) -> (# s1, wordToWord64# res #)
+#endif
+
genSym :: IO Word64
genSym = do
let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1
let !(Ptr counter) = ghc_unique_counter64
let !(Ptr inc_ptr) = ghc_unique_inc
- u <- IO $ \s0 -> case readWordOffAddr# inc_ptr 0# s0 of
- (# s1, inc #) -> case fetchAddWordAddr# counter inc s1 of
+ u <- IO $ \s0 -> case readWord64OffAddr# inc_ptr 0# s0 of
+ (# s1, inc #) -> case fetchAddWord64Addr# counter inc s1 of
(# s2, val #) ->
-#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
- let !u = W64# (val `plusWord#` inc) .&. mask
-#else
- let !u = W64# (wordToWord64# (val `plusWord#` inc)) .&. mask
-#endif
+ let !u = W64# (val `plusWord64#` inc) .&. mask
in (# s2, u #)
#if defined(DEBUG)
-- Uh oh! We will overflow next time a unique is requested.
@@ -254,7 +271,6 @@ genSym = do
massert (u /= mask)
#endif
return u
-#endif
foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64
foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int
=====================================
compiler/cbits/genSym.c
=====================================
@@ -16,26 +16,3 @@ HsWord64 ghc_unique_counter64 = 0;
HsInt ghc_unique_inc = 1;
#endif
-// This function has been added to the RTS. Here we pessimistically assume
-// that a threaded RTS is used. This function is only used for bootstrapping.
-#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
-EXTERN_INLINE StgWord64
-atomic_inc64(StgWord64 volatile* p, StgWord64 incr)
-{
-#if defined(HAVE_C11_ATOMICS)
- return __atomic_add_fetch(p, incr, __ATOMIC_SEQ_CST);
-#else
- return __sync_add_and_fetch(p, incr);
-#endif
-}
-#endif
-
-#define UNIQUE_BITS (sizeof (HsWord64) * 8 - UNIQUE_TAG_BITS)
-#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)
-
-HsWord64 genSym(void) {
- HsWord64 u = atomic_inc64((StgWord64 *)&ghc_unique_counter64, ghc_unique_inc) & UNIQUE_MASK;
- // Uh oh! We will overflow next time a unique is requested.
- ASSERT(u != UNIQUE_MASK);
- return u;
-}
=====================================
compiler/jsbits/genSym.js
=====================================
@@ -16,11 +16,3 @@ var h$ghc_unique_counter64 = h$newByteArray(8);
h$ghc_unique_counter64.i3[0] = 0;
h$ghc_unique_counter64.i3[1] = 0;
-function h$genSym() {
- var rl = h$hs_plusWord64(h$ghc_unique_counter64.i3[1] >>> 0, h$ghc_unique_counter64.i3[0] >>> 0, 0, h$ghc_unique_inc.i3[0] >>> 0);
- h$ret1 = (h$ret1 & HIGH_UNIQUE_MASK) >>> 0;
- // h$ret1 contains the higher part (rh)
- h$ghc_unique_counter64.i3[0] = rl | 0;
- h$ghc_unique_counter64.i3[1] = h$ret1 | 0;
- return rl; // h$ret1 still contains rh
-}
=====================================
testsuite/tests/ghc-e/should_fail/T24172.hs
=====================================
@@ -0,0 +1 @@
+main = print $ 1 + Bool
=====================================
testsuite/tests/ghc-e/should_fail/T24172.stderr
=====================================
@@ -0,0 +1,8 @@
+
+[;1mT24172.hs:1:20: [;1m[31merror[0m[0m[;1m: [GHC-01928][0m[0m[;1m
+ • Illegal term-level use of the type constructor ‘Bool’
+ • imported from ‘Prelude’ at T24172.hs:1:1
+ (and originally defined in ‘GHC.Types’)
+ • In the second argument of ‘(+)’, namely ‘Bool’
+ In the second argument of ‘($)’, namely ‘1 + Bool’
+ In the expression: print $ 1 + Bool[0m[0m
=====================================
testsuite/tests/ghc-e/should_fail/all.T
=====================================
@@ -56,3 +56,5 @@ test('T18441fail18', req_interp, makefile_test, ['T18441fail18'])
test('T18441fail19', [ignore_stderr, exit_code(1)], run_command, ['{compiler} -e ":cd abcd"'])
test('T23663', req_interp, makefile_test, ['T23663'])
+
+test('T24172', normal, compile_fail, ['-fdiagnostics-color=always'])
=====================================
testsuite/tests/typecheck/should_fail/T24298.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE ImplicitParams, MagicHash #-}
+module T24298 where
+
+f = let ?foo = 4# in True
=====================================
testsuite/tests/typecheck/should_fail/T24298.stderr
=====================================
@@ -0,0 +1,9 @@
+
+T24298.hs:4:16: error: [GHC-18872]
+ • Couldn't match a lifted type with an unlifted type
+ When matching types
+ t0 :: *
+ GHC.Prim.Int# :: TYPE GHC.Types.IntRep
+ • In the expression: 4#
+ In the expression: let ?foo = 4# in True
+ In an equation for ‘f’: f = let ?foo = 4# in True
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -710,3 +710,4 @@ test('T23776', normal, compile_fail, ['']) # error due to -Werror=compat, schedu
test('T17940', normal, compile_fail, [''])
test('ErrorIndexLinks', normal, compile_fail, ['-fprint-error-index-links=always'])
test('T24064', normal, compile_fail, [''])
+test('T24298', normal, compile_fail, [''])
=====================================
testsuite/tests/warnings/should_fail/Colour.stderr
=====================================
@@ -1,5 +1,5 @@
-[;1mColour.hs:1:8: [;1m[31merror[0m[0m[;1m: [[;1m[31mGHC-83865[0m[0m[;1m][0m[0m[;1m
+[;1mColour.hs:1:8: [;1m[31merror[0m[0m[;1m: [GHC-83865][0m[0m[;1m
• Couldn't match expected type ‘IO ()’ with actual type ‘()’
• In the expression: () :: IO ()
In an equation for ‘main’: main = () :: IO ()[0m[0m
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/30258e5ce7f9556a70e4f2d0a2e187e0291cad40...1640940fe8787dedf8c62ac78544053626d5af4f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/30258e5ce7f9556a70e4f2d0a2e187e0291cad40...1640940fe8787dedf8c62ac78544053626d5af4f
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/20231229/52b8b6b8/attachment-0001.html>
More information about the ghc-commits
mailing list