[Git][ghc/ghc][master] 3 commits: testsuite: Add test for atomicSwapIORef
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue May 9 22:39:39 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b970e64f by Ben Gamari at 2023-05-09T08:41:33-04:00
testsuite: Add test for atomicSwapIORef
- - - - -
81cfefd2 by Ben Gamari at 2023-05-09T08:41:53-04:00
compiler: Implement atomicSwapIORef with xchg
As requested by @treeowl in CLC#139.
- - - - -
6b29154d by Ben Gamari at 2023-05-09T08:41:53-04:00
Make atomicSwapMutVar# an inline primop
- - - - -
8 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/base/GHC/IORef.hs
- + libraries/base/tests/AtomicSwapIORef.hs
- + libraries/base/tests/AtomicSwapIORef.stdout
- libraries/base/tests/all.T
- rts/include/Cmm.h
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2604,6 +2604,12 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp
has_side_effects = True
code_size = { primOpCodeSizeForeignCall } -- for the write barrier
+primop AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp
+ MutVar# s v -> v -> State# s -> (# State# s, v #)
+ {Atomically exchange the value of a 'MutVar#'.}
+ with
+ has_side_effects = True
+
-- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Looking at the type of atomicModifyMutVar2#, one might wonder why
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -297,16 +297,12 @@ emitPrimOp cfg primop =
-- MutVar's value.
emitPrimCall [] (MO_AtomicWrite (wordWidth platform) MemOrderRelease)
[ cmmOffsetW platform mutv (fixedHdrSizeW profile), var ]
+ emitDirtyMutVar mutv (CmmReg old_val)
- platform <- getPlatform
- mkdirtyMutVarCCall <- getCode $! emitCCall
- [{-no results-}]
- (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
- [(baseExpr platform, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]
- emit =<< mkCmmIfThen
- (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel)
- (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv))
- mkdirtyMutVarCCall
+ AtomicSwapMutVarOp -> \[mutv, val] -> opIntoRegs $ \[res] -> do
+ let dst = cmmOffsetW platform mutv (fixedHdrSizeW profile)
+ emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val]
+ emitDirtyMutVar mutv (CmmReg (CmmLocal res))
-- #define sizzeofByteArrayzh(r,a) \
-- r = ((StgArrBytes *)(a))->bytes
@@ -3331,6 +3327,21 @@ doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do
then emitBoundsCheck idx effective_arr_sz -- aligned => simpler check
else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz)
+-- | Write barrier for @MUT_VAR@ modification.
+emitDirtyMutVar :: CmmExpr -> CmmExpr -> FCode ()
+emitDirtyMutVar mutvar old_val = do
+ cfg <- getStgToCmmConfig
+ platform <- getPlatform
+ mkdirtyMutVarCCall <- getCode $! emitCCall
+ [{-no results-}]
+ (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
+ [(baseExpr platform, AddrHint), (mutvar, AddrHint), (old_val, AddrHint)]
+
+ emit =<< mkCmmIfThen
+ (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel)
+ (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutvar))
+ mkdirtyMutVarCCall
+
---------------------------------------------------------------------------
-- Pushing to the update remembered set
---------------------------------------------------------------------------
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -801,6 +801,8 @@ genPrim prof bound ty op = case op of
AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f]
AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f]
+ AtomicSwapMutVarOp -> \[r] [mv,v] -> PrimInline $ mconcat
+ [ r |= mv .^ "val", mv .^ "val" |= v ]
CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o)
(mconcat [status |= zero_, r |= n, mv .^ "val" |= n])
(mconcat [status |= one_ , r |= mv .^ "val"])
=====================================
libraries/base/GHC/IORef.hs
=====================================
@@ -127,12 +127,7 @@ atomicModifyIORef'_ ref f = do
-- | Atomically replace the contents of an 'IORef', returning
-- the old contents.
atomicSwapIORef :: IORef a -> a -> IO a
--- Bad implementation! This will be a primop shortly.
-atomicSwapIORef (IORef (STRef ref)) new = IO $ \s ->
- case atomicModifyMutVar2# ref (\_old -> Box new) s of
- (# s', old, Box _new #) -> (# s', old #)
-
-data Box a = Box a
+atomicSwapIORef (IORef (STRef ref)) new = IO (atomicSwapMutVar# ref new)
-- | A strict version of 'Data.IORef.atomicModifyIORef'. This forces both the
-- value stored in the 'IORef' and the value returned.
=====================================
libraries/base/tests/AtomicSwapIORef.hs
=====================================
@@ -0,0 +1,10 @@
+import Data.IORef
+import GHC.IORef
+import Data.Word
+
+main :: IO ()
+main = do
+ r <- newIORef 42 :: IO (IORef Int)
+ mapM (atomicSwapIORef r) [0..1000] >>= print
+ mapM (atomicSwapIORef r) [0..1000000] >>= print . sum . map (fromIntegral :: Int -> Integer)
+ readIORef r >>= print
=====================================
libraries/base/tests/AtomicSwapIORef.stdout
=====================================
@@ -0,0 +1,3 @@
+[42,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999]
+499999501000
+1000000
=====================================
libraries/base/tests/all.T
=====================================
@@ -298,3 +298,4 @@ test('listThreads', normal, compile_and_run, [''])
test('listThreads1', normal, compile_and_run, [''])
test('inits1tails1', normal, compile_and_run, [''])
test('CLC149', normal, compile, [''])
+test('AtomicSwapIORef', normal, compile_and_run, [''])
=====================================
rts/include/Cmm.h
=====================================
@@ -193,8 +193,10 @@
#if SIZEOF_W == 4
#define cmpxchgW cmpxchg32
+#define xchgW xchg32
#elif SIZEOF_W == 8
#define cmpxchgW cmpxchg64
+#define xchgW xchg64
#endif
/* -----------------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e2df4c9ac59a10080bd6e029e83a355ecd01c8b...6b29154de6b63597553c5b69b9974c8838a7a80a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e2df4c9ac59a10080bd6e029e83a355ecd01c8b...6b29154de6b63597553c5b69b9974c8838a7a80a
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/20230509/ccece02d/attachment-0001.html>
More information about the ghc-commits
mailing list