atomic-counter (empty) → 0.1
raw patch · 11 files changed
+1681/−0 lines, 11 filesdep +QuickCheckdep +asyncdep +atomic-counter
Dependencies added: QuickCheck, async, atomic-counter, base, primitive, stm, tasty, tasty-bench, tasty-quickcheck
Files
- Changelog.md +3/−0
- LICENSE +202/−0
- Readme.md +712/−0
- atomic-counter.cabal +137/−0
- bench/BenchMain.hs +145/−0
- src/Control/Concurrent/Counter.hs +16/−0
- src/Control/Concurrent/Counter/Lifted/IO.hs +101/−0
- src/Control/Concurrent/Counter/Lifted/ST.hs +117/−0
- src/Control/Concurrent/Counter/Unlifted.hs +117/−0
- test/TestMain.hs +42/−0
- test/TestUtils.hs +89/−0
+ Changelog.md view
@@ -0,0 +1,3 @@+# 0.1++Initial release
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright 2022 Sergey Vinokurov++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ Readme.md view
@@ -0,0 +1,712 @@+[](https://github.com/sergv/atomic-counter/actions/workflows/haskell-ci.yaml)++# Synopsis++Mutable cells that hold an integer value and can be safely modified from+multiple threads. Support only few operations: read, write, +, -, and+bitwise and, or, xor and nand.++Good use case is a shared counter that multiple threads increment.++Operations translate to atomic CPU instructions which make these cells+way faster that even vanilla `IORef`. Value inside the cell is unboxed+which contributes to outperforming all other shared vars because they+box the value they store. For integers boxing is especially bad.++# Benchmark++### Summary++Depending on number of threads `Counter` from this package can be+up to 10 times faster than next best `TVar` from the `stm` package.++### Details++The benchmark is to spawn N threads each of which will increment the+same counter by 1 for a number of iterations.++Test setup: Intel i5-9600K CPU @ 3.70GHz, 6 cores, no hyperthreading, GHC 9.4.4.++NB `IORef inconsistent` is the benchmark that just reads and writes+`IORef` with the fastest functions the `IORef` supports. It gives+wrong results when multiple threads access `IORef` this way since+these reads and writes are not synchronized. It’s included only for+speed comparison purposes. All others do proper synchronization of+increments between the threads. Current package is shown as `Counter`.++```+$ cabal run --builddir /tmp/dist bench -- -j1 --timeout 30+All+ Correctness: OK (15.52s)+ +++ OK, passed 10000 tests.+ Read/write contention with 10 iterations and 1 threads+ Counter: OK (0.42s)+ 785 ns ± 27 ns+ IORef inconsistent: OK (0.16s)+ 1.12 μs ± 95 ns+ IORef atomic: OK (0.16s)+ 1.08 μs ± 99 ns+ MVar: OK (0.62s)+ 1.15 μs ± 40 ns+ TMVar: OK (0.50s)+ 896 ns ± 31 ns+ TVar: OK (0.15s)+ 1.01 μs ± 92 ns+ Addr: OK (0.74s)+ 679 ns ± 48 ns+ Read/write contention with 100 iterations and 1 threads+ Counter: OK (0.15s)+ 1.01 μs ± 89 ns+ IORef inconsistent: OK (0.23s)+ 3.38 μs ± 198 ns+ IORef atomic: OK (0.44s)+ 3.03 μs ± 91 ns+ MVar: OK (0.24s)+ 3.35 μs ± 167 ns+ TMVar: OK (0.17s)+ 4.64 μs ± 328 ns+ TVar: OK (0.14s)+ 4.09 μs ± 372 ns+ Addr: OK (0.57s)+ 1.04 μs ± 43 ns+ Read/write contention with 1000 iterations and 1 threads+ Counter: OK (0.17s)+ 4.80 μs ± 389 ns+ IORef inconsistent: OK (0.16s)+ 18.4 μs ± 1.4 μs+ IORef atomic: OK (0.19s)+ 23.3 μs ± 2.1 μs+ MVar: OK (0.13s)+ 15.6 μs ± 1.3 μs+ TMVar: OK (0.21s)+ 49.5 μs ± 4.8 μs+ TVar: OK (0.16s)+ 38.3 μs ± 3.3 μs+ Addr: OK (0.22s)+ 5.88 μs ± 369 ns+ Read/write contention with 10000 iterations and 1 threads+ Counter: OK (0.18s)+ 41.8 μs ± 2.7 μs+ IORef inconsistent: OK (0.23s)+ 224 μs ± 21 μs+ IORef atomic: OK (0.18s)+ 169 μs ± 15 μs+ MVar: OK (0.20s)+ 187 μs ± 15 μs+ TMVar: OK (0.21s)+ 409 μs ± 25 μs+ TVar: OK (0.16s)+ 304 μs ± 25 μs+ Addr: OK (0.22s)+ 52.7 μs ± 4.1 μs+ Read/write contention with 10 iterations and 2 threads+ Counter: OK (0.11s)+ 7.05 μs ± 667 ns+ IORef inconsistent: OK (0.22s)+ 7.43 μs ± 599 ns+ IORef atomic: OK (0.22s)+ 7.19 μs ± 719 ns+ MVar: OK (0.47s)+ 7.42 μs ± 671 ns+ TMVar: OK (0.24s)+ 8.01 μs ± 773 ns+ TVar: OK (0.22s)+ 7.45 μs ± 585 ns+ Addr: OK (0.23s)+ 6.99 μs ± 601 ns+ Read/write contention with 100 iterations and 2 threads+ Counter: OK (0.16s)+ 8.88 μs ± 749 ns+ IORef inconsistent: OK (0.16s)+ 12.1 μs ± 975 ns+ IORef atomic: OK (0.16s)+ 12.1 μs ± 736 ns+ MVar: OK (0.13s)+ 17.6 μs ± 1.7 μs+ TMVar: OK (0.18s)+ 29.7 μs ± 2.2 μs+ TVar: OK (0.14s)+ 24.8 μs ± 2.0 μs+ Addr: OK (0.29s)+ 8.52 μs ± 555 ns+ Read/write contention with 1000 iterations and 2 threads+ Counter: OK (0.85s)+ 42.8 μs ± 1.2 μs+ IORef inconsistent: OK (4.85s)+ 140 μs ± 2.1 μs+ IORef atomic: OK (0.30s)+ 277 μs ± 12 μs+ MVar: OK (0.33s)+ 5.29 ms ± 224 μs+ TMVar: OK (0.64s)+ 270 μs ± 16 μs+ TVar: OK (0.64s)+ 306 μs ± 18 μs+ Addr: OK (0.23s)+ 47.4 μs ± 2.1 μs+ Read/write contention with 10000 iterations and 2 threads+ Counter: OK (0.11s)+ 298 μs ± 28 μs+ IORef inconsistent: OK (0.08s)+ 1.01 ms ± 99 μs+ IORef atomic: OK (0.99s)+ 1.26 ms ± 19 μs+ MVar: OK (0.45s)+ 62.7 ms ± 3.9 ms+ TMVar: OK (0.42s)+ 2.96 ms ± 257 μs+ TVar: OK (6.90s)+ 3.26 ms ± 149 μs+ Addr: OK (0.08s)+ 527 μs ± 45 μs+ Read/write contention with 10 iterations and 4 threads+ Counter: OK (0.16s)+ 15.0 μs ± 820 ns+ IORef inconsistent: OK (0.17s)+ 16.4 μs ± 946 ns+ IORef atomic: OK (0.38s)+ 19.2 μs ± 937 ns+ MVar: OK (0.20s)+ 27.5 μs ± 2.4 μs+ TMVar: OK (0.10s)+ 20.2 μs ± 1.3 μs+ TVar: OK (0.19s)+ 18.2 μs ± 781 ns+ Addr: OK (0.09s)+ 15.5 μs ± 1.4 μs+ Read/write contention with 100 iterations and 4 threads+ Counter: OK (0.40s)+ 23.1 μs ± 1.8 μs+ IORef inconsistent: OK (0.09s)+ 56.3 μs ± 4.7 μs+ IORef atomic: OK (0.24s)+ 157 μs ± 3.9 μs+ MVar: OK (0.16s)+ 1.20 ms ± 115 μs+ TMVar: OK (0.07s)+ 193 μs ± 19 μs+ TVar: OK (0.13s)+ 214 μs ± 7.9 μs+ Addr: OK (0.39s)+ 22.3 μs ± 491 ns+ Read/write contention with 1000 iterations and 4 threads+ Counter: OK (0.17s)+ 242 μs ± 13 μs+ IORef inconsistent: OK (0.07s)+ 485 μs ± 32 μs+ IORef atomic: OK (2.02s)+ 1.51 ms ± 54 μs+ MVar: OK (0.19s)+ 12.4 ms ± 1.2 ms+ TMVar: OK (0.14s)+ 2.01 ms ± 76 μs+ TVar: OK (0.07s)+ 1.92 ms ± 99 μs+ Addr: OK (0.08s)+ 233 μs ± 12 μs+ Read/write contention with 10000 iterations and 4 threads+ Counter: OK (0.17s)+ 2.44 ms ± 82 μs+ IORef inconsistent: OK (0.08s)+ 4.49 ms ± 291 μs+ IORef atomic: OK (0.84s)+ 18.3 ms ± 941 μs+ MVar: OK (0.39s)+ 125 ms ± 12 ms+ TMVar: OK (0.16s)+ 18.7 ms ± 1.8 ms+ TVar: OK (0.08s)+ 18.8 ms ± 1.3 ms+ Addr: OK (0.67s)+ 2.27 ms ± 80 μs+ Read/write contention with 10 iterations and 6 threads+ Counter: OK (0.23s)+ 24.1 μs ± 1.7 μs+ IORef inconsistent: OK (0.25s)+ 26.1 μs ± 1.4 μs+ IORef atomic: OK (0.18s)+ 41.1 μs ± 2.2 μs+ MVar: OK (0.32s)+ 46.8 μs ± 3.2 μs+ TMVar: OK (0.53s)+ 33.8 μs ± 2.5 μs+ TVar: OK (0.07s)+ 32.5 μs ± 2.7 μs+ Addr: OK (0.12s)+ 24.5 μs ± 2.4 μs+ Read/write contention with 100 iterations and 6 threads+ Counter: OK (0.29s)+ 40.2 μs ± 3.1 μs+ IORef inconsistent: OK (0.12s)+ 100 μs ± 5.9 μs+ IORef atomic: OK (0.14s)+ 352 μs ± 30 μs+ MVar: OK (0.12s)+ 1.82 ms ± 168 μs+ TMVar: OK (0.92s)+ 544 μs ± 43 μs+ TVar: OK (0.23s)+ 561 μs ± 28 μs+ Addr: OK (0.30s)+ 38.9 μs ± 2.1 μs+ Read/write contention with 1000 iterations and 6 threads+ Counter: OK (0.87s)+ 477 μs ± 4.3 μs+ IORef inconsistent: OK (0.20s)+ 1.01 ms ± 61 μs+ IORef atomic: OK (0.85s)+ 3.05 ms ± 154 μs+ MVar: OK (0.62s)+ 19.8 ms ± 1.5 ms+ TMVar: OK (0.06s)+ 4.65 ms ± 428 μs+ TVar: OK (0.25s)+ 4.78 ms ± 117 μs+ Addr: OK (0.22s)+ 477 μs ± 32 μs+ Read/write contention with 10000 iterations and 6 threads+ Counter: OK (2.01s)+ 4.82 ms ± 131 μs+ IORef inconsistent: OK (0.12s)+ 9.87 ms ± 230 μs+ IORef atomic: OK (6.61s)+ 66.0 ms ± 24 ms+ MVar: OK (1.31s)+ 194 ms ± 3.5 ms+ TMVar: OK (0.63s)+ 52.3 ms ± 290 μs+ TVar: OK (0.07s)+ 48.5 ms ± 4.5 ms+ Addr: OK (0.03s)+ 4.82 ms ± 479 μs+ Read/write contention with 10 iterations and 8 threads+ Counter: OK (0.13s)+ 26.3 μs ± 2.1 μs+ IORef inconsistent: OK (0.16s)+ 28.8 μs ± 1.8 μs+ IORef atomic: OK (0.25s)+ 56.2 μs ± 5.2 μs+ MVar: OK (0.71s)+ 95.8 μs ± 9.1 μs+ TMVar: OK (0.19s)+ 52.3 μs ± 1.8 μs+ TVar: OK (0.18s)+ 47.9 μs ± 2.0 μs+ Addr: OK (0.13s)+ 26.1 μs ± 1.9 μs+ Read/write contention with 100 iterations and 8 threads+ Counter: OK (0.05s)+ 60.9 μs ± 5.5 μs+ IORef inconsistent: OK (0.58s)+ 120 μs ± 2.4 μs+ IORef atomic: OK (0.62s)+ 706 μs ± 9.6 μs+ MVar: OK (0.16s)+ 2.26 ms ± 209 μs+ TMVar: OK (0.07s)+ 571 μs ± 53 μs+ TVar: OK (0.28s)+ 556 μs ± 6.8 μs+ Addr: OK (0.10s)+ 58.8 μs ± 5.0 μs+ Read/write contention with 1000 iterations and 8 threads+ Counter: OK (0.28s)+ 588 μs ± 17 μs+ IORef inconsistent: OK (1.07s)+ 1.15 ms ± 8.3 μs+ IORef atomic: OK (5.86s)+ 6.91 ms ± 986 μs+ MVar: OK (0.71s)+ 22.9 ms ± 842 μs+ TMVar: OK (0.16s)+ 6.10 ms ± 542 μs+ TVar: OK (0.09s)+ 5.76 ms ± 457 μs+ Addr: OK (0.07s)+ 624 μs ± 49 μs+ Read/write contention with 10000 iterations and 8 threads+ Counter: OK (0.65s)+ 5.99 ms ± 259 μs+ IORef inconsistent: OK (0.08s)+ 11.4 ms ± 403 μs+ IORef atomic: OK (9.50s)+ 160 ms ± 43 ms+ MVar: OK (0.74s)+ 246 ms ± 21 ms+ TMVar: OK (0.04s)+ 50.4 ms ± 3.0 ms+ TVar: OK (0.79s)+ 58.5 ms ± 1.3 ms+ Addr: OK (0.17s)+ 5.51 ms ± 226 μs+ Read/write contention with 10 iterations and 12 threads+ Counter: OK (0.14s)+ 29.8 μs ± 2.8 μs+ IORef inconsistent: OK (0.08s)+ 34.5 μs ± 2.8 μs+ IORef atomic: OK (0.27s)+ 71.0 μs ± 3.3 μs+ MVar: OK (0.23s)+ 229 μs ± 15 μs+ TMVar: OK (0.87s)+ 81.1 μs ± 697 ns+ TVar: OK (0.21s)+ 76.2 μs ± 5.6 μs+ Addr: OK (0.14s)+ 29.3 μs ± 2.3 μs+ Read/write contention with 100 iterations and 12 threads+ Counter: OK (0.25s)+ 92.8 μs ± 7.8 μs+ IORef inconsistent: OK (0.06s)+ 179 μs ± 16 μs+ IORef atomic: OK (0.43s)+ 976 μs ± 30 μs+ MVar: OK (0.43s)+ 3.07 ms ± 172 μs+ TMVar: OK (0.11s)+ 946 μs ± 44 μs+ TVar: OK (0.24s)+ 1.05 ms ± 43 μs+ Addr: OK (0.24s)+ 90.4 μs ± 4.5 μs+ Read/write contention with 1000 iterations and 12 threads+ Counter: OK (0.11s)+ 1.01 ms ± 37 μs+ IORef inconsistent: OK (0.10s)+ 1.76 ms ± 174 μs+ IORef atomic: OK (2.73s)+ 11.9 ms ± 434 μs+ MVar: OK (0.28s)+ 36.3 ms ± 2.7 ms+ TMVar: OK (0.07s)+ 10.6 ms ± 819 μs+ TVar: OK (0.25s)+ 9.24 ms ± 596 μs+ Addr: OK (0.84s)+ 902 μs ± 61 μs+ Read/write contention with 10000 iterations and 12 threads+ Counter: OK (0.25s)+ 9.15 ms ± 853 μs+ IORef inconsistent: OK (0.12s)+ 18.7 ms ± 904 μs+ IORef atomic: OK (2.28s)+ 292 ms ± 19 ms+ MVar: OK (5.38s)+ 350 ms ± 4.1 ms+ TMVar: OK (2.57s)+ 104 ms ± 5.6 ms+ TVar: OK (0.62s)+ 104 ms ± 3.0 ms+ Addr: OK (0.12s)+ 9.65 ms ± 799 μs+ Read/write contention with 10 iterations and 16 threads+ Counter: OK (0.09s)+ 40.4 μs ± 2.8 μs+ IORef inconsistent: OK (0.11s)+ 47.7 μs ± 2.9 μs+ IORef atomic: OK (0.29s)+ 133 μs ± 8.6 μs+ MVar: OK (0.76s)+ 390 μs ± 13 μs+ TMVar: OK (0.08s)+ 98.5 μs ± 6.9 μs+ TVar: OK (1.18s)+ 125 μs ± 10 μs+ Addr: OK (0.09s)+ 40.6 μs ± 2.7 μs+ Read/write contention with 100 iterations and 16 threads+ Counter: OK (0.08s)+ 133 μs ± 6.5 μs+ IORef inconsistent: OK (0.14s)+ 275 μs ± 9.8 μs+ IORef atomic: OK (1.04s)+ 1.28 ms ± 31 μs+ MVar: OK (0.57s)+ 4.34 ms ± 330 μs+ TMVar: OK (0.60s)+ 1.39 ms ± 8.3 μs+ TVar: OK (0.16s)+ 1.40 ms ± 73 μs+ Addr: OK (0.16s)+ 130 μs ± 12 μs+ Read/write contention with 1000 iterations and 16 threads+ Counter: OK (0.30s)+ 1.31 ms ± 82 μs+ IORef inconsistent: OK (0.14s)+ 2.51 ms ± 56 μs+ IORef atomic: OK (3.03s)+ 14.6 ms ± 1.4 ms+ MVar: OK (0.71s)+ 46.5 ms ± 3.9 ms+ TMVar: OK (0.08s)+ 13.8 ms ± 721 μs+ TVar: OK (0.69s)+ 12.8 ms ± 806 μs+ Addr: OK (0.29s)+ 1.33 ms ± 23 μs+ Read/write contention with 10000 iterations and 16 threads+ Counter: OK (0.16s)+ 12.9 ms ± 1.1 ms+ IORef inconsistent: OK (0.15s)+ 25.5 ms ± 2.2 ms+ IORef atomic: OK (8.01s)+ 515 ms ± 51 ms+ MVar: OK (1.57s)+ 501 ms ± 31 ms+ TMVar: OK (0.88s)+ 149 ms ± 11 ms+ TVar: OK (1.72s)+ 145 ms ± 1.1 ms+ Addr: OK (0.08s)+ 11.4 ms ± 480 μs+ Read/write contention with 10 iterations and 20 threads+ Counter: OK (0.11s)+ 50.2 μs ± 4.9 μs+ IORef inconsistent: OK (0.10s)+ 57.2 μs ± 3.8 μs+ IORef atomic: OK (0.35s)+ 192 μs ± 17 μs+ MVar: OK (0.26s)+ 533 μs ± 29 μs+ TMVar: OK (0.10s)+ 162 μs ± 14 μs+ TVar: OK (0.05s)+ 166 μs ± 11 μs+ Addr: OK (0.09s)+ 48.5 μs ± 3.3 μs+ Read/write contention with 100 iterations and 20 threads+ Counter: OK (0.05s)+ 170 μs ± 14 μs+ IORef inconsistent: OK (0.16s)+ 334 μs ± 11 μs+ IORef atomic: OK (0.53s)+ 1.44 ms ± 112 μs+ MVar: OK (0.35s)+ 5.29 ms ± 217 μs+ TMVar: OK (0.05s)+ 1.90 ms ± 114 μs+ TVar: OK (0.05s)+ 1.75 ms ± 111 μs+ Addr: OK (0.05s)+ 131 μs ± 11 μs+ Read/write contention with 1000 iterations and 20 threads+ Counter: OK (0.18s)+ 1.73 ms ± 38 μs+ IORef inconsistent: OK (0.04s)+ 3.06 ms ± 305 μs+ IORef atomic: OK (0.44s)+ 17.4 ms ± 797 μs+ MVar: OK (1.80s)+ 56.3 ms ± 1.3 ms+ TMVar: OK (0.44s)+ 18.7 ms ± 761 μs+ TVar: OK (0.05s)+ 18.3 ms ± 1.8 ms+ Addr: OK (0.05s)+ 1.72 ms ± 103 μs+ Read/write contention with 10000 iterations and 20 threads+ Counter: OK (0.05s)+ 17.6 ms ± 1.2 ms+ IORef inconsistent: OK (0.04s)+ 31.2 ms ± 1.8 ms+ IORef atomic: OK (10.54s)+ 659 ms ± 346 ms+ MVar: OK (1.96s)+ 627 ms ± 46 ms+ TMVar: OK (1.10s)+ 192 ms ± 9.0 ms+ TVar: OK (1.09s)+ 183 ms ± 16 ms+ Addr: OK (0.21s)+ 17.0 ms ± 260 μs+ Read/write contention with 10 iterations and 32 threads+ Counter: OK (0.12s)+ 70.1 μs ± 2.7 μs+ IORef inconsistent: OK (0.08s)+ 86.8 μs ± 7.5 μs+ IORef atomic: OK (0.95s)+ 183 μs ± 12 μs+ MVar: OK (0.23s)+ 913 μs ± 46 μs+ TMVar: OK (0.07s)+ 281 μs ± 15 μs+ TVar: OK (0.07s)+ 283 μs ± 20 μs+ Addr: OK (0.12s)+ 69.4 μs ± 3.2 μs+ Read/write contention with 100 iterations and 32 threads+ Counter: OK (0.05s)+ 280 μs ± 27 μs+ IORef inconsistent: OK (0.06s)+ 487 μs ± 37 μs+ IORef atomic: OK (0.07s)+ 1.89 ms ± 121 μs+ MVar: OK (0.57s)+ 8.50 ms ± 703 μs+ TMVar: OK (0.04s)+ 3.04 ms ± 280 μs+ TVar: OK (0.07s)+ 2.95 ms ± 175 μs+ Addr: OK (0.04s)+ 277 μs ± 26 μs+ Read/write contention with 1000 iterations and 32 threads+ Counter: OK (0.08s)+ 2.75 ms ± 198 μs+ IORef inconsistent: OK (0.03s)+ 5.20 ms ± 388 μs+ IORef atomic: OK (0.39s)+ 22.5 ms ± 809 μs+ MVar: OK (0.68s)+ 92.3 ms ± 4.3 ms+ TMVar: OK (0.18s)+ 31.4 ms ± 2.2 ms+ TVar: OK (0.09s)+ 30.0 ms ± 2.5 ms+ Addr: OK (0.04s)+ 2.85 ms ± 243 μs+ Read/write contention with 10000 iterations and 32 threads+ Counter: OK (0.08s)+ 28.1 ms ± 708 μs+ IORef inconsistent: OK (0.07s)+ 53.6 ms ± 1.4 ms+ IORef atomic: OK (9.80s)+ 1.223 s ± 410 ms+ MVar: OK (7.32s)+ 1.009 s ± 37 ms+ TMVar: OK (0.17s)+ 296 ms ± 23 ms+ TVar: OK (1.76s)+ 302 ms ± 5.6 ms+ Addr: OK (0.08s)+ 29.1 ms ± 2.6 ms+ Read/write contention with 10 iterations and 64 threads+ Counter: OK (0.05s)+ 127 μs ± 12 μs+ IORef inconsistent: OK (0.12s)+ 158 μs ± 5.8 μs+ IORef atomic: OK (0.05s)+ 320 μs ± 29 μs+ MVar: OK (0.23s)+ 1.86 ms ± 145 μs+ TMVar: OK (1.06s)+ 529 μs ± 41 μs+ TVar: OK (0.26s)+ 569 μs ± 24 μs+ Addr: OK (0.06s)+ 125 μs ± 11 μs+ Read/write contention with 100 iterations and 64 threads+ Counter: OK (0.04s)+ 564 μs ± 47 μs+ IORef inconsistent: OK (0.04s)+ 1.03 ms ± 98 μs+ IORef atomic: OK (0.31s)+ 3.96 ms ± 240 μs+ MVar: OK (1.15s)+ 17.6 ms ± 1.3 ms+ TMVar: OK (0.30s)+ 6.30 ms ± 476 μs+ TVar: OK (0.30s)+ 6.28 ms ± 66 μs+ Addr: OK (0.06s)+ 560 μs ± 24 μs+ Read/write contention with 1000 iterations and 64 threads+ Counter: OK (0.14s)+ 4.93 ms ± 91 μs+ IORef inconsistent: OK (0.03s)+ 8.83 ms ± 711 μs+ IORef atomic: OK (6.68s)+ 110 ms ± 21 ms+ MVar: OK (1.34s)+ 188 ms ± 7.7 ms+ TMVar: OK (0.36s)+ 64.3 ms ± 4.0 ms+ TVar: OK (0.08s)+ 64.3 ms ± 2.3 ms+ Addr: OK (0.04s)+ 5.85 ms ± 457 μs+ Read/write contention with 10000 iterations and 64 threads+ Counter: OK (0.08s)+ 59.1 ms ± 2.2 ms+ IORef inconsistent: OK (0.14s)+ 102 ms ± 5.3 ms+ IORef atomic: OK (11.44s)+ 2.924 s ± 306 ms+ MVar: OK (6.17s)+ 1.982 s ± 34 ms+ TMVar: OK (0.35s)+ 657 ms ± 5.3 ms+ TVar: OK (3.62s)+ 631 ms ± 83 ms+ Addr: OK (0.03s)+ 47.7 ms ± 3.7 ms+ Read/write contention with 10 iterations and 128 threads+ Counter: OK (0.08s)+ 232 μs ± 11 μs+ IORef inconsistent: OK (0.12s)+ 322 μs ± 11 μs+ IORef atomic: OK (0.36s)+ 636 μs ± 14 μs+ MVar: OK (0.23s)+ 3.65 ms ± 264 μs+ TMVar: OK (1.04s)+ 1.07 ms ± 59 μs+ TVar: OK (0.07s)+ 1.09 ms ± 97 μs+ Addr: OK (0.05s)+ 227 μs ± 22 μs+ Read/write contention with 100 iterations and 128 threads+ Counter: OK (0.04s)+ 1.16 ms ± 85 μs+ IORef inconsistent: OK (0.03s)+ 2.08 ms ± 182 μs+ IORef atomic: OK (0.07s)+ 5.79 ms ± 393 μs+ MVar: OK (1.14s)+ 35.6 ms ± 1.1 ms+ TMVar: OK (0.62s)+ 13.1 ms ± 417 μs+ TVar: OK (0.07s)+ 10.4 ms ± 412 μs+ Addr: OK (0.13s)+ 1.10 ms ± 95 μs+ Read/write contention with 1000 iterations and 128 threads+ Counter: OK (0.04s)+ 11.7 ms ± 1.2 ms+ IORef inconsistent: OK (0.06s)+ 21.8 ms ± 2.0 ms+ IORef atomic: OK (10.69s)+ 318 ms ± 82 ms+ MVar: OK (5.87s)+ 373 ms ± 8.3 ms+ TMVar: OK (0.36s)+ 133 ms ± 4.1 ms+ TVar: OK (0.17s)+ 128 ms ± 8.6 ms+ Addr: OK (0.07s)+ 10.0 ms ± 504 μs+ Read/write contention with 10000 iterations and 128 threads+ Counter: OK (0.33s)+ 119 ms ± 8.4 ms+ IORef inconsistent: OK (0.28s)+ 210 ms ± 11 ms+ IORef atomic: OK (11.27s)+ 6.930 s ± 818 ms+ MVar: OK (12.48s)+ 3.977 s ± 43 ms+ TMVar: OK (3.52s)+ 1.316 s ± 11 ms+ TVar: OK (1.60s)+ 1.291 s ± 126 ms+ Addr: OK (0.67s)+ 118 ms ± 3.0 ms++All 309 tests passed (264.24s)+```++# Memory overhead++Each unlifted value of type `Counter` is a singleton mutable array+from GHC primitives under the hood. Thus it occupies at least+`platform integer size` + `array size` + `header` bytes which should+typically be at least 3 machine words. Lifted values may occupy more+depending on optimizations.
+ atomic-counter.cabal view
@@ -0,0 +1,137 @@+cabal-version: 3.0++-- Created : 29 December 2022++name:+ atomic-counter+version:+ 0.1+synopsis:+ Mutable counters that can be modified with atomic operatinos++description:+ This package defines Counter type that can be safely modified+ concurrently from multiple threads. The supports only few operations,+ namely read, write, add, subtract and a few bitwise ones like or, and, xor.++ Most common use case is having a shared counter that multiple threads increment.++copyright:+ (c) Sergey Vinokurov 2022+license:+ Apache-2.0+license-file:+ LICENSE+author:+ Sergey Vinokurov+maintainer:+ Sergey Vinokurov <serg.foo@gmail.com>+category:+ Concurrency, Data, Data Structures++build-type:+ Simple++extra-source-files:+ Changelog.md+ Readme.md++homepage:+ https://github.com/sergv/atomic-counter++source-repository head+ type: git+ location: https://github.com/sergv/atomic-counter.git++common ghc-options+ default-language:+ Haskell2010++ ghc-options:+ -Weverything+ -Wno-all-missed-specialisations+ -Wno-implicit-prelude+ -Wno-missed-specialisations+ -Wno-missing-import-lists+ -Wno-missing-local-signatures+ -Wno-missing-safe-haskell-mode+ -Wno-safe+ -Wno-type-defaults+ -Wno-unsafe++ if impl(ghc >= 8.8)+ ghc-options:+ -Wno-missing-deriving-strategies++ if impl(ghc >= 9.2)+ ghc-options:+ -Wno-missing-kind-signatures++library+ import: ghc-options+ exposed-modules:+ Control.Concurrent.Counter+ Control.Concurrent.Counter.Lifted.IO+ Control.Concurrent.Counter.Lifted.ST+ Control.Concurrent.Counter.Unlifted+ hs-source-dirs:+ src+ build-depends:+ , base >= 4.14 && < 5++library test-utils+ import: ghc-options+ exposed-modules:+ TestUtils+ hs-source-dirs:+ test+ build-depends:+ , QuickCheck+ , async >= 2+ , base >= 4.14++test-suite test+ import: ghc-options+ type:+ exitcode-stdio-1.0+ main-is:+ test/TestMain.hs+ hs-source-dirs:+ .+ build-depends:+ , QuickCheck+ , atomic-counter+ , base >= 4.14+ , tasty+ , tasty-quickcheck+ , test-utils+ ghc-options:+ -rtsopts+ -threaded+ "-with-rtsopts=-N -A32M"+ -main-is TestMain++benchmark bench+ import: ghc-options+ type:+ exitcode-stdio-1.0+ main-is:+ bench/BenchMain.hs+ hs-source-dirs:+ .+ build-depends:+ , QuickCheck+ , atomic-counter+ , base >= 4.14+ , primitive+ , stm+ , tasty+ , tasty-bench+ , tasty-quickcheck+ , test-utils+ ghc-options:+ -rtsopts+ -threaded+ "-with-rtsopts=-N -A32M"+ -main-is BenchMain+
+ bench/BenchMain.hs view
@@ -0,0 +1,145 @@+----------------------------------------------------------------------------+-- |+-- Module : BenchMain+-- Copyright : (c) Sergey Vinokurov 2022+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE UnboxedTuples #-}++module BenchMain (main) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Data.IORef+import Data.Primitive.Types+import Data.Semigroup+import GHC.Exts+import GHC.IO+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.Bench+import Test.Tasty.QuickCheck qualified as QC+import Test.Tasty.Runners qualified as Tasty++import Control.Concurrent.Counter.Lifted.IO qualified as C++import TestUtils++#if MIN_VERSION_base(4, 16, 0)+readAddr :: Addr# -> Word+readAddr addr = W# (indexWordOffAddr# addr 0#)++withAddr :: (Addr# -> IO a) -> IO a+withAddr f = IO $ \s1 -> case newPinnedByteArray# (sizeOf# (undefined :: Word)) s1 of+ (# s2, mbarr #) ->+ let !addr = mutableByteArrayContents# mbarr in+ case writeWordOffAddr# addr 0# 0## s2 of+ s3 -> case unIO (f addr) s3 of+ (# s4, res #) -> case touch# mbarr s4 of+ s5 -> (# s5, res #)++incrementAddr :: Addr# -> Int -> IO ()+incrementAddr addr (I# delta) = IO $ \s1 -> case fetchAddWordAddr# addr (int2Word# delta) s1 of+ (# s2, _ #) -> (# s2, () #)+#endif++incrementIORef :: IORef Int -> Int -> IO ()+incrementIORef !x !delta = atomicModifyIORef' x (\old -> (old + delta, ()))++incrementIORefInconsistent :: IORef Int -> Int -> IO ()+incrementIORefInconsistent !x !delta = do+ n <- readIORef x+ writeIORef x $! n + delta++incrementMVar :: MVar Int -> Int -> IO ()+incrementMVar !x !delta = do+ !n <- takeMVar x+ putMVar x $! n + delta++incrementTMVar :: TMVar Int -> Int -> IO ()+incrementTMVar !x !delta = atomically $ do+ !n <- takeTMVar x+ putTMVar x $! n + delta++incrementTVar :: TVar Int -> Int -> IO ()+incrementTVar !x !delta = atomically $ modifyTVar' x (+ delta)++incrementCounter :: C.Counter -> Int -> IO ()+incrementCounter !x !delta = void (C.add x delta)+++main :: IO ()+main = do+ let tests =+ [ localOption (QC.QuickCheckTests 10000) $+ QC.testProperty "Correctness" $+ \(Threads ts) -> ioProperty $ do++ a <- spawnAndCall ts (newIORef 0) (\ref t -> runThread t (\_ -> pure ()) (incrementIORef ref)) >>= readIORef+ b <- spawnAndCall ts (newMVar 0) (\ref t -> runThread t (\_ -> pure ()) (incrementMVar ref)) >>= takeMVar+ c <- spawnAndCall ts (newTMVarIO 0) (\ref t -> runThread t (\_ -> pure ()) (incrementTMVar ref)) >>= atomically . takeTMVar+ d <- spawnAndCall ts (newTVarIO 0) (\ref t -> runThread t (\_ -> pure ()) (incrementTVar ref)) >>= atomically . readTVar+ -- e <- spawnAndCall ts (newIORef 0) (\ref t -> runThread t (incrementIORefInconsistent ref *> sleep delay)) >>= readIORef+#if MIN_VERSION_base(4, 16, 0)+ f <- withAddr $ \addr -> do+ spawnAndCall ts (pure ()) (\() t -> runThread t (\_ -> pure ()) (incrementAddr addr))+ evaluate (readAddr addr)+#endif++ g <- spawnAndCall ts (C.new 0) (\ref t -> runThread t (\_ -> pure ()) (incrementCounter ref)) >>= C.get++ let Sum expected =+ foldMap (\Thread{tIncrement, tIterations} -> Sum $ tIncrement * unIterations tIterations) ts++ pure $+ a === expected .&&.+ b === expected .&&.+ c === expected .&&.+ d === expected .&&.+#if MIN_VERSION_base(4, 16, 0)+ fromIntegral f === expected .&&.+#endif+ g === expected+ ]++ let benchmarks =+ [ bgroup ("Read/write contention with " ++ show (unIterations n) ++ " iterations and " ++ show (length threads) ++ " threads")+ [ bench "Counter" $+ whnfIO (spawnAndCall threads (C.new 0) (\ref _ -> callN n (incrementCounter ref 1)))+ , bench "IORef inconsistent" $+ whnfIO (spawnAndCall threads (newIORef 0) (\ref _ -> callN n (incrementIORefInconsistent ref 1)))+ , bench "IORef atomic" $+ whnfIO (spawnAndCall threads (newIORef 0) (\ref _ -> callN n (incrementIORef ref 1)))+ , bench "MVar" $+ whnfIO (spawnAndCall threads (newMVar 0) (\ref _ -> callN n (incrementMVar ref 1)))+ , bench "TMVar" $+ whnfIO (spawnAndCall threads (newTMVarIO 0) (\ref _ -> callN n (incrementTMVar ref 1)))+ , bench "TVar" $+ whnfIO (spawnAndCall threads (newTVarIO 0) (\ref _ -> callN n (incrementTVar ref 1)))+#if MIN_VERSION_base(4, 16, 0)+ , bench "Addr" $+ whnfIO $ withAddr $ \addr -> do+ spawnAndCall+ threads+ (pure ())+ (\() _ -> callN n (incrementAddr addr 1))+ evaluate (readAddr addr)+#endif+ ]+ | repeats <- [1, 2, 4, 6, 8, 12, 16, 20, 32, 64, 128]+ , let threads = [1..repeats]+ , n <- [Iterations 10, Iterations 100, Iterations 1000, Iterations 10000]+ ]++ defaultMainWithIngredients benchIngredients $+ localOption (Tasty.NumThreads 1) $+ testGroup "All" $+ tests ++ benchmarks
+ src/Control/Concurrent/Counter.hs view
@@ -0,0 +1,16 @@+----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.Counter+-- Copyright : (c) Sergey Vinokurov 2022+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+--+-- Work with lifted 'Counter' values in the 'IO' monad. Please see other+-- modules in this package for 'Control.Monad.ST.ST' monad and for unlifted values.+----------------------------------------------------------------------------++module Control.Concurrent.Counter+ ( module Control.Concurrent.Counter.Lifted.IO+ ) where++import Control.Concurrent.Counter.Lifted.IO
+ src/Control/Concurrent/Counter/Lifted/IO.hs view
@@ -0,0 +1,101 @@+----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.Counter.Lifted.IO+-- Copyright : (c) Sergey Vinokurov 2022+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+--+-- Lifted 'Control.Concurrent.Counter.Lifted.Counter' specialized to+-- operate in the 'IO' monad.+----------------------------------------------------------------------------++{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeApplications #-}++module Control.Concurrent.Counter.Lifted.IO+ ( Counter++ -- * Create+ , new++ -- * Read/write+ , get+ , set++ -- * Arithmetic operations+ , add+ , sub++ -- * Bitwise operations+ , and+ , or+ , xor+ , nand+ ) where++import Prelude hiding (and, or)++import Data.Coerce+import GHC.Exts (RealWorld)+import GHC.IO+import GHC.ST++import Control.Concurrent.Counter.Lifted.ST qualified as Lifted+++-- | Memory location that supports select few atomic operations.+--+-- Isomorphic to @IORef Int@.+newtype Counter = Counter (Lifted.Counter RealWorld)++-- | Pointer equality+instance Eq Counter where+ (==) = coerce ((==) @(Lifted.Counter RealWorld))++{-# INLINE new #-}+-- | Create new counter with initial value.+new :: Int -> IO Counter+new = coerce . stToIO . Lifted.new+++{-# INLINE get #-}+-- | Atomically read the counter's value.+get :: Counter -> IO Int+get = coerce Lifted.get++{-# INLINE set #-}+-- | Atomically assign new value to the counter.+set :: Counter -> Int -> IO ()+set = coerce Lifted.set+++{-# INLINE add #-}+-- | Atomically add an amount to the counter and return its old value.+add :: Counter -> Int -> IO Int+add = coerce Lifted.add++{-# INLINE sub #-}+-- | Atomically subtract an amount from the counter and return its old value.+sub :: Counter -> Int -> IO Int+sub = coerce Lifted.sub+++{-# INLINE and #-}+-- | Atomically combine old value with a new one via bitwise and. Returns old counter value.+and :: Counter -> Int -> IO Int+and = coerce Lifted.and++{-# INLINE or #-}+-- | Atomically combine old value with a new one via bitwise or. Returns old counter value.+or :: Counter -> Int -> IO Int+or = coerce Lifted.or++{-# INLINE xor #-}+-- | Atomically combine old value with a new one via bitwise xor. Returns old counter value.+xor :: Counter -> Int -> IO Int+xor = coerce Lifted.xor++{-# INLINE nand #-}+-- | Atomically combine old value with a new one via bitwise nand. Returns old counter value.+nand :: Counter -> Int -> IO Int+nand = coerce Lifted.nand
+ src/Control/Concurrent/Counter/Lifted/ST.hs view
@@ -0,0 +1,117 @@+----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.Counter.Lifted.ST+-- Copyright : (c) Sergey Vinokurov 2022+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+--+-- Counters that support some atomic operations. Safe to use from+-- multiple threads and likely faster than using IORef or TVar for the+-- same operation (terms and conditions apply).+----------------------------------------------------------------------------++{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++module Control.Concurrent.Counter.Lifted.ST+ ( Counter++ -- * Create+ , new++ -- * Read/write+ , get+ , set++ -- * Arithmetic operations+ , add+ , sub++ -- * Bitwise operations+ , and+ , or+ , xor+ , nand+ ) where++import Prelude hiding (and, or)++import GHC.Exts (Int(..), Int#, State#)+import GHC.ST++import Control.Concurrent.Counter.Unlifted qualified as Unlifted+++-- | Memory location that supports select few atomic operations.+--+-- Isomorphic to @STRef s Int@.+data Counter s = Counter (Unlifted.Counter s)++-- | Pointer equality+instance Eq (Counter s) where+ Counter x == Counter y = Unlifted.sameCounter x y+++{-# INLINE new #-}+-- | Create new counter with initial value.+new :: Int -> ST s (Counter s)+new (I# initVal) = ST $ \s1 -> case Unlifted.new initVal s1 of+ (# s2, c #) -> (# s2, Counter c #)+++{-# INLINE get #-}+-- | Atomically read the counter's value.+get+ :: Counter s+ -> ST s Int+get (Counter c) = ST $ \s1 -> case Unlifted.get c s1 of+ (# s2, x #) -> (# s2, I# x #)++{-# INLINE set #-}+-- | Atomically assign new value to the counter.+set+ :: Counter s+ -> Int+ -> ST s ()+set (Counter c) (I# x) = ST $ \s1 -> case Unlifted.set c x s1 of+ s2 -> (# s2, () #)+++{-# INLINE add #-}+-- | Atomically add an amount to the counter and return its old value.+add :: Counter s -> Int -> ST s Int+add = toST Unlifted.add++{-# INLINE sub #-}+-- | Atomically subtract an amount from the counter and return its old value.+sub :: Counter s -> Int -> ST s Int+sub = toST Unlifted.sub+++{-# INLINE and #-}+-- | Atomically combine old value with a new one via bitwise and. Returns old counter value.+and :: Counter s -> Int -> ST s Int+and = toST Unlifted.and++{-# INLINE or #-}+-- | Atomically combine old value with a new one via bitwise or. Returns old counter value.+or :: Counter s -> Int -> ST s Int+or = toST Unlifted.or++{-# INLINE xor #-}+-- | Atomically combine old value with a new one via bitwise xor. Returns old counter value.+xor :: Counter s -> Int -> ST s Int+xor = toST Unlifted.xor++{-# INLINE nand #-}+-- | Atomically combine old value with a new one via bitwise nand. Returns old counter value.+nand :: Counter s -> Int -> ST s Int+nand = toST Unlifted.nand++{-# INLINE toST #-}+toST+ :: (Unlifted.Counter s -> Int# -> State# s -> (# State# s, Int# #))+ -> Counter s -> Int -> ST s Int+toST f = \(Counter c) (I# x) -> ST $ \s1 -> case f c x s1 of+ (# s2, old #) -> (# s2, I# old #)
+ src/Control/Concurrent/Counter/Unlifted.hs view
@@ -0,0 +1,117 @@+----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.Counter.Unlifted+-- Copyright : (c) Sergey Vinokurov 2022+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+--+-- Counters that support some atomic operations. Safe to use from+-- multiple threads and likely faster than using 'Data.IORef.IORef' or+-- 'Control.Concurrent.STM.TVar.TVar' for the same operation (terms and+-- conditions apply).+--+-- This module defines unlifted newtype wrapper and corresponding operations,+-- they're not suitable for use with e.g. monads or being stored in other+-- data structures that expect lifted types. For general use start with+-- 'Control.Concurrent.Counter.Counter' module.+----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedNewtypes #-}++module Control.Concurrent.Counter.Unlifted+ ( Counter++ -- * Create+ , new++ -- * Read/write+ , get+ , set++ -- * Arithmetic operations+ , add+ , sub++ -- * Bitwise operations+ , and+ , or+ , xor+ , nand++ -- * Compare+ , sameCounter+ ) where++import Prelude hiding (and, or)++import GHC.Exts++#include "MachDeps.h"+#ifndef SIZEOF_HSINT+#error "MachDeps.h didn't define SIZEOF_HSINT"+#endif++#define ADD_HASH(x) x#++-- | Memory location that supports select few atomic operations.+newtype Counter s = Counter (MutableByteArray# s)++{-# INLINE new #-}+-- | Create new counter with initial value.+new :: Int# -> State# s -> (# State# s, Counter s #)+new initVal = \s1 -> case newByteArray# ADD_HASH(SIZEOF_HSINT) s1 of+ (# s2, arr #) ->+ case writeIntArray# arr 0# initVal s2 of+ s3 -> (# s3, Counter arr #)+++{-# INLINE get #-}+-- | Atomically read the counter's value.+get :: Counter s -> State# s -> (# State# s, Int# #)+get (Counter arr) = atomicReadIntArray# arr 0#++{-# INLINE set #-}+-- | Atomically assign new value to the counter.+set :: Counter s -> Int# -> State# s -> State# s+set (Counter arr) = atomicWriteIntArray# arr 0#+++{-# INLINE add #-}+-- | Atomically add an amount to the counter and return its old value.+add :: Counter s -> Int# -> State# s -> (# State# s, Int# #)+add (Counter arr) = fetchAddIntArray# arr 0#++{-# INLINE sub #-}+-- | Atomically subtract an amount from the counter and return its old value.+sub :: Counter s -> Int# -> State# s -> (# State# s, Int# #)+sub (Counter arr) = fetchSubIntArray# arr 0#+++{-# INLINE and #-}+-- | Atomically combine old value with a new one via bitwise and. Returns old counter value.+and :: Counter s -> Int# -> State# s -> (# State# s, Int# #)+and (Counter arr) = fetchAndIntArray# arr 0#++{-# INLINE or #-}+-- | Atomically combine old value with a new one via bitwise or. Returns old counter value.+or :: Counter s -> Int# -> State# s -> (# State# s, Int# #)+or (Counter arr) = fetchOrIntArray# arr 0#++{-# INLINE xor #-}+-- | Atomically combine old value with a new one via bitwise xor. Returns old counter value.+xor :: Counter s -> Int# -> State# s -> (# State# s, Int# #)+xor (Counter arr) = fetchXorIntArray# arr 0#++{-# INLINE nand #-}+-- | Atomically combine old value with a new one via bitwise nand. Returns old counter value.+nand :: Counter s -> Int# -> State# s -> (# State# s, Int# #)+nand (Counter arr) = fetchNandIntArray# arr 0#+++-- | Compare the underlying pointers of two counters.+sameCounter :: Counter s -> Counter s -> Bool+sameCounter (Counter x) (Counter y) =+ isTrue# (sameMutableByteArray# x y)
+ test/TestMain.hs view
@@ -0,0 +1,42 @@+----------------------------------------------------------------------------+-- |+-- Module : TestMain+-- Copyright : (c) Sergey Vinokurov 2022+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NamedFieldPuns #-}++module TestMain (main) where++import Data.Semigroup+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck qualified as QC+import Test.Tasty.Runners qualified as Tasty++import Control.Concurrent.Counter.Lifted.IO qualified as C++import TestUtils++main :: IO ()+main = defaultMain $+ localOption (Tasty.NumThreads 1) $+ testGroup "All"+ [ adjustOption (\(QC.QuickCheckTests x) -> QC.QuickCheckTests (max x 500)) $+ QC.testProperty "Correctness" $+ \(Threads ts) -> ioProperty $ do+ res <- spawnAndCall ts (C.new 0) (\ref t -> runThread t sleep (C.add ref)) >>= C.get+ let Sum expected =+ foldMap (\Thread{tIncrement, tIterations} -> Sum $ tIncrement * unIterations tIterations) ts+ pure $ res === expected+ , adjustOption (\(QC.QuickCheckTests x) -> QC.QuickCheckTests (max x 10000)) $+ QC.testProperty "Correctness, no delays" $+ \(Threads ts) -> ioProperty $ do+ res <- spawnAndCall ts (C.new 0) (\ref t -> runThread t (\_ -> pure ()) (C.add ref)) >>= C.get+ let Sum expected =+ foldMap (\Thread{tIncrement, tIterations} -> Sum $ tIncrement * unIterations tIterations) ts+ pure $ res === expected+ ]
+ test/TestUtils.hs view
@@ -0,0 +1,89 @@+----------------------------------------------------------------------------+-- |+-- Module : TestUtils+-- Copyright : (c) Sergey Vinokurov 2022+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NamedFieldPuns #-}++module TestUtils+ ( Delay(..)+ , sleep+ , Iterations(..)+ , callN+ , Thread(..)+ , runThread+ , Threads(..)+ , spawnAndCall+ ) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad+import Control.Monad.IO.Class+import Data.Foldable+import Data.List.NonEmpty (NonEmpty(..))+import GHC.Generics (Generic)+import Test.QuickCheck++-- In microseconds+newtype Delay = Delay { unDelay :: Int }+ deriving (Eq, Show)++sleep :: MonadIO m => Delay -> m ()+sleep (Delay n) = case n of+ 0 -> pure ()+ k -> liftIO $ threadDelay k++instance Arbitrary Delay where+ arbitrary = Delay <$> chooseInt (0, 10)+ shrink = map Delay . filter (\x -> 0 <= x && x <= 25) . shrink . unDelay++newtype Iterations = Iterations { unIterations :: Int }+ deriving (Eq, Show)++instance Arbitrary Iterations where+ arbitrary = Iterations <$> chooseInt (0, 50)+ shrink = map Iterations . filter (\x -> 0 <= x && x <= 50) . shrink . unIterations++callN :: Applicative m => Iterations -> m a -> m ()+callN (Iterations !n) action = go n+ where+ go !k =+ if k > 0+ then action *> go (k - 1)+ else pure ()++data Thread = Thread+ { tDelay :: Delay+ , tIncrement :: Int+ , tIterations :: Iterations+ } deriving (Eq, Show, Generic)++instance Arbitrary Thread where+ arbitrary = Thread <$> arbitrary <*> chooseInt (-1000, 1000) <*> arbitrary+ shrink = filter ((<= 1000) . abs . tIncrement) . genericShrink++runThread :: MonadIO m => Thread -> (Delay -> m a) -> (Int -> m b) -> m ()+runThread Thread{tDelay, tIncrement, tIterations} doSleep f =+ callN tIterations (f tIncrement *> doSleep tDelay)++newtype Threads = Threads { unThreads :: NonEmpty Thread }+ deriving (Eq, Show)++instance Arbitrary Threads where+ arbitrary = do+ n <- chooseInt (0, 31)+ Threads <$> ((:|) <$> arbitrary <*> replicateM n arbitrary)+ shrink = map Threads . genericShrink . unThreads++spawnAndCall :: Traversable f => f b -> IO a -> (a -> b -> IO ()) -> IO a+spawnAndCall threads mkRes action = do+ res <- mkRes+ traverse_ wait =<< traverse (async . action res) threads+ pure res+