[Git][ghc/ghc][wip/T22010] Fix genSym & add fetchAddWord64Addr
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Fri Jun 2 12:38:58 UTC 2023
Jaro Reinders pushed to branch wip/T22010 at Glasgow Haskell Compiler / GHC
Commits:
b28a1da8 by Jaro Reinders at 2023-06-02T14:38:44+02:00
Fix genSym & add fetchAddWord64Addr
- - - - -
9 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Driver/CmdLine.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/Types/Unique/Supply.hs
- compiler/cbits/genSym.c
- rts/include/stg/SMP.h
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2576,6 +2576,14 @@ primop FetchAddAddrOp_Word "fetchAddWordAddr#" GenPrimOp
with has_side_effects = True
can_fail = True
+primop FetchAddAddrOp_Word64 "fetchAddWord64Addr#" GenPrimOp
+ Addr# -> Word64# -> State# s -> (# State# s, Word64# #)
+ {Given an address, and a value to add,
+ atomically add the value to the element. Returns the value of the
+ element before the operation. Implies a full memory barrier.}
+ with has_side_effects = True
+ can_fail = True
+
primop FetchSubAddrOp_Word "fetchSubWordAddr#" GenPrimOp
Addr# -> Word# -> State# s -> (# State# s, Word# #)
{Given an address, and a value to subtract,
=====================================
compiler/GHC/Driver/CmdLine.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Utils.Outputable (text)
import Data.Function
import Data.List (sortBy, intercalate, stripPrefix)
+import Data.Word
import GHC.ResponseFile
import Control.Exception (IOException, catch)
@@ -75,7 +76,7 @@ hoistFlag f (Flag a b c) = Flag a (go b) c
go (OptPrefix k) = OptPrefix (\s -> go2 (k s))
go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n))
go (IntSuffix k) = IntSuffix (\n -> go2 (k n))
- go (WordSuffix k) = WordSuffix (\s -> go2 (k s))
+ go (Word64Suffix k) = Word64Suffix (\s -> go2 (k s))
go (FloatSuffix k) = FloatSuffix (\s -> go2 (k s))
go (PassFlag k) = PassFlag (\s -> go2 (k s))
go (AnySuffix k) = AnySuffix (\s -> go2 (k s))
@@ -98,7 +99,7 @@ data OptKind m -- Suppose the flag is -f
| OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional)
| OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn
| IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn
- | WordSuffix (Word -> EwM m ()) -- -f or -f=n; pass n to fn
+ | Word64Suffix (Word64 -> EwM m ()) -- -f or -f=n; pass n to fn
| FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn
| PassFlag (String -> EwM m ()) -- -f; pass "-f" fn
| AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn
@@ -240,7 +241,7 @@ processOneArg opt_kind rest arg args
IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
| otherwise -> Left ("malformed integer argument in " ++ dash_arg)
- WordSuffix f | Just n <- parseWord rest_no_eq -> Right (f n, args)
+ Word64Suffix f | Just n <- parseWord64 rest_no_eq -> Right (f n, args)
| otherwise -> Left ("malformed natural argument in " ++ dash_arg)
FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)
@@ -269,7 +270,7 @@ arg_ok (Prefix _) _ _ = True -- Missing argument checked for in p
-- to improve error message (#12625)
arg_ok (OptIntSuffix _) _ _ = True
arg_ok (IntSuffix _) _ _ = True
-arg_ok (WordSuffix _) _ _ = True
+arg_ok (Word64Suffix _) _ _ = True
arg_ok (FloatSuffix _) _ _ = True
arg_ok (OptPrefix _) _ _ = True
arg_ok (PassFlag _) rest _ = null rest
@@ -285,8 +286,8 @@ parseInt s = case reads s of
((n,""):_) -> Just n
_ -> Nothing
-parseWord :: String -> Maybe Word
-parseWord s = case reads s of
+parseWord64 :: String -> Maybe Word64
+parseWord64 s = case reads s of
((n,""):_) -> Just n
_ -> Nothing
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -117,6 +117,7 @@ import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.Writer (WriterT)
import Data.IORef
+import Data.Word
import System.IO
import System.IO.Error (catchIOError)
import System.Environment (lookupEnv)
@@ -449,7 +450,7 @@ data DynFlags = DynFlags {
maxErrors :: Maybe Int,
-- | Unique supply configuration for testing build determinism
- initialUnique :: Word,
+ initialUnique :: Word64,
uniqueIncrement :: Int,
-- 'Int' because it can be used to test uniques in decreasing order.
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -276,6 +276,7 @@ import Data.List (intercalate, sortBy)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Data.Word
import System.FilePath
import Text.ParserCombinators.ReadP hiding (char)
import Text.ParserCombinators.ReadP as R
@@ -957,8 +958,8 @@ add_dep_message (OptIntSuffix f) message =
OptIntSuffix $ \oi -> f oi >> deprecate message
add_dep_message (IntSuffix f) message =
IntSuffix $ \i -> f i >> deprecate message
-add_dep_message (WordSuffix f) message =
- WordSuffix $ \i -> f i >> deprecate message
+add_dep_message (Word64Suffix f) message =
+ Word64Suffix $ \i -> f i >> deprecate message
add_dep_message (FloatSuffix f) message =
FloatSuffix $ \fl -> f fl >> deprecate message
add_dep_message (PassFlag f) message =
@@ -1735,7 +1736,7 @@ dynamic_flags_deps = [
, make_ord_flag defGhcFlag "fmax-inline-memset-insns"
(intSuffix (\n d -> d { maxInlineMemsetInsns = n }))
, make_ord_flag defGhcFlag "dinitial-unique"
- (wordSuffix (\n d -> d { initialUnique = n }))
+ (word64Suffix (\n d -> d { initialUnique = n }))
, make_ord_flag defGhcFlag "dunique-increment"
(intSuffix (\n d -> d { uniqueIncrement = n }))
@@ -2960,8 +2961,8 @@ intSuffix fn = IntSuffix (\n -> upd (fn n))
intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)
intSuffixM fn = IntSuffix (\n -> updM (fn n))
-wordSuffix :: (Word -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
-wordSuffix fn = WordSuffix (\n -> upd (fn n))
+word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
+word64Suffix fn = Word64Suffix (\n -> upd (fn n))
floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
floatSuffix fn = FloatSuffix (\n -> upd (fn n))
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -821,6 +821,8 @@ emitPrimOp cfg primop =
FetchAddAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->
doAtomicAddrRMW res AMO_Add addr (bWord platform) n
+ FetchAddAddrOp_Word64 -> \[addr, n] -> opIntoRegs $ \[res] ->
+ doAtomicAddrRMW res AMO_Add addr b64 n
FetchSubAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->
doAtomicAddrRMW res AMO_Sub addr (bWord platform) n
FetchAndAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1043,6 +1043,8 @@ genPrim prof bound ty op = case op of
CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl)
FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v
+ -- TODO:
+ -- FetchAddAddrOp_Word64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ appT [rh,rl] "h$hs_fetchAddWord64Addr" [a,i,oh,ol,nh,nl]
FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v
FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v
FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -42,10 +42,18 @@ import Control.Monad
import Data.Char
import Data.Word
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
+import Foreign.Storable
+import GHC.Word (Word64(..))
+
+#include "MachDeps.h"
+
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
-import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# )
+#if WORD_SIZE_IN_BITS < 64
+import GHC.Exts( fetchAddWord64Addr#, plusWord64#, readWord64OffAddr# )
+#else
+import GHC.Exts( fetchAddWordAddr#, plusWord#, readWordOffAddr# )
+#endif
#endif
-import Foreign.Storable
#include "Unique.h"
@@ -223,30 +231,37 @@ mkSplitUniqSupply c
}}}}
#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
-foreign import ccall unsafe "genSym" genSym :: IO Word64 -- TODO: Word64 is a lie
+foreign import ccall unsafe "genSym" genSym :: IO Word64
#else
genSym :: IO Word64
genSym = do
let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1
let !(Ptr counter) = ghc_unique_counter
let !(Ptr inc_ptr) = ghc_unique_inc
+#if WORD_SIZE_IN_BITS < 64
+ u <- IO $ \s0 -> case readWord64OffAddr# inc_ptr 0# s0 of
+ (# s1, inc #) -> case fetchAddWord64Addr# counter inc s1 of
+ (# s2, val #) ->
+ let !u = W64# (val `plusWord64#` inc) .&. mask
+#else
u <- IO $ \s0 -> case readWordOffAddr# inc_ptr 0# s0 of
(# s1, inc #) -> case fetchAddWordAddr# counter inc s1 of
(# s2, val #) ->
- let !u = I# (word2Int# (val `plusWord#` inc)) .&. mask
+ let !u = W64# (val `plusWord#` inc) .&. mask
+#endif
in (# s2, u #)
#if defined(DEBUG)
-- Uh oh! We will overflow next time a unique is requested.
-- (Note that if the increment isn't 1 we may miss this check)
massert (u /= mask)
#endif
- return (undefined u)
+ return u
#endif
-foreign import ccall unsafe "&ghc_unique_counter" ghc_unique_counter :: Ptr Word
+foreign import ccall unsafe "&ghc_unique_counter" ghc_unique_counter :: Ptr Word64
foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int
-initUniqSupply :: Word -> Int -> IO ()
+initUniqSupply :: Word64 -> Int -> IO ()
initUniqSupply counter inc = do
poke ghc_unique_counter counter
poke ghc_unique_inc inc
@@ -254,7 +269,7 @@ initUniqSupply counter inc = do
uniqFromMask :: Char -> IO Unique
uniqFromMask !mask
= do { uqNum <- genSym
- ; return $! mkUnique mask uqNum }
+ ; return $! mkUnique64 mask uqNum }
{-# NOINLINE uniqFromMask #-} -- We'll unbox everything, but we don't want to inline it
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
=====================================
compiler/cbits/genSym.c
=====================================
@@ -10,15 +10,15 @@
// The CPP is thus about the RTS version GHC is linked against, and not the
// version of the GHC being built.
#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
-HsInt ghc_unique_counter = 0;
+HsWord64 ghc_unique_counter = 0;
HsInt ghc_unique_inc = 1;
#endif
-#define UNIQUE_BITS (sizeof (HsInt) * 8 - UNIQUE_TAG_BITS)
+#define UNIQUE_BITS (sizeof (HsWord64) * 8 - UNIQUE_TAG_BITS)
#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)
-HsInt genSym(void) {
- HsInt u = atomic_inc((StgWord *)&ghc_unique_counter, ghc_unique_inc) & UNIQUE_MASK;
+HsWord64 genSym(void) {
+ HsWord64 u = atomic_inc64((StgWord *)&ghc_unique_counter, ghc_unique_inc) & UNIQUE_MASK;
// Uh oh! We will overflow next time a unique is requested.
ASSERT(u != UNIQUE_MASK);
return u;
=====================================
rts/include/stg/SMP.h
=====================================
@@ -87,6 +87,15 @@ EXTERN_INLINE StgWord cas_seq_cst_relaxed(StgVolatilePtr p, StgWord o, StgWord n
EXTERN_INLINE StgWord atomic_inc(StgVolatilePtr p, StgWord n);
+/*
+ * Atomic 64-bit addition of by the provided quantity
+ *
+ * atomic_inc64(p, n) {
+ * return ((*p) += n);
+ * }
+ */
+EXTERN_INLINE StgWord64 atomic_inc64(StgVolatilePtr p, StgWord64 n);
+
/*
* Atomic decrement
*
@@ -430,6 +439,16 @@ atomic_inc(StgVolatilePtr p, StgWord incr)
#endif
}
+EXTERN_INLINE StgWord64
+atomic_inc64(StgVolatilePtr 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
+}
+
EXTERN_INLINE StgWord
atomic_dec(StgVolatilePtr p)
{
@@ -659,6 +678,14 @@ atomic_inc(StgVolatilePtr p, StgWord incr)
}
+EXTERN_INLINE StgWord atomic_inc64(StgVolatilePtr p, StgWord64 incr);
+EXTERN_INLINE StgWord64
+atomic_inc64(StgVolatilePtr p, StgWord64 incr)
+{
+ return ((*p) += incr);
+}
+
+
INLINE_HEADER StgWord
atomic_dec(StgVolatilePtr p)
{
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b28a1da8b92cf2d5cde4faeec273702b20615364
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b28a1da8b92cf2d5cde4faeec273702b20615364
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/20230602/de239072/attachment-0001.html>
More information about the ghc-commits
mailing list