diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,3 @@ +# 0.1 + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Readme.md b/Readme.md new file mode 100644 --- /dev/null +++ b/Readme.md @@ -0,0 +1,712 @@ +[![build](https://github.com/sergv/atomic-counter/actions/workflows/haskell-ci.yaml/badge.svg)](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. diff --git a/atomic-counter.cabal b/atomic-counter.cabal new file mode 100644 --- /dev/null +++ b/atomic-counter.cabal @@ -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 +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 + diff --git a/bench/BenchMain.hs b/bench/BenchMain.hs new file mode 100644 --- /dev/null +++ b/bench/BenchMain.hs @@ -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 diff --git a/src/Control/Concurrent/Counter.hs b/src/Control/Concurrent/Counter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Counter.hs @@ -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 diff --git a/src/Control/Concurrent/Counter/Lifted/IO.hs b/src/Control/Concurrent/Counter/Lifted/IO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Counter/Lifted/IO.hs @@ -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 diff --git a/src/Control/Concurrent/Counter/Lifted/ST.hs b/src/Control/Concurrent/Counter/Lifted/ST.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Counter/Lifted/ST.hs @@ -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 #) diff --git a/src/Control/Concurrent/Counter/Unlifted.hs b/src/Control/Concurrent/Counter/Unlifted.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Counter/Unlifted.hs @@ -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) diff --git a/test/TestMain.hs b/test/TestMain.hs new file mode 100644 --- /dev/null +++ b/test/TestMain.hs @@ -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 + ] diff --git a/test/TestUtils.hs b/test/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils.hs @@ -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 +