├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── README.md ├── cabal.project ├── ki-unlifted ├── CHANGELOG.md ├── LICENSE ├── ki-unlifted.cabal └── src │ └── Ki │ └── Unlifted.hs └── ki ├── CHANGELOG.md ├── LICENSE ├── README.md ├── ki.cabal ├── src ├── Ki.hs └── Ki │ └── Internal │ ├── ByteCount.hs │ ├── IO.hs │ ├── NonblockingSTM.hs │ ├── Propagating.hs │ ├── Scope.hs │ ├── Thread.hs │ ├── ThreadAffinity.hs │ └── ThreadOptions.hs └── test └── Tests.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250216 12 | # 13 | # REGENDATA ("0.19.20250216",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.1 32 | compilerKind: ghc 33 | compilerVersion: 9.12.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | fail-fast: false 47 | steps: 48 | - name: apt-get install 49 | run: | 50 | apt-get update 51 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 52 | - name: Install GHCup 53 | run: | 54 | mkdir -p "$HOME/.ghcup/bin" 55 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 56 | chmod a+x "$HOME/.ghcup/bin/ghcup" 57 | - name: Install cabal-install 58 | run: | 59 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 60 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 61 | - name: Install GHC (GHCup) 62 | if: matrix.setup-method == 'ghcup' 63 | run: | 64 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 65 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 66 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 67 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 68 | echo "HC=$HC" >> "$GITHUB_ENV" 69 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 70 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 71 | env: 72 | HCKIND: ${{ matrix.compilerKind }} 73 | HCNAME: ${{ matrix.compiler }} 74 | HCVER: ${{ matrix.compilerVersion }} 75 | - name: Set PATH and environment variables 76 | run: | 77 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 78 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 79 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 80 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 81 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 82 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 83 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 84 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 85 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 86 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 87 | env: 88 | HCKIND: ${{ matrix.compilerKind }} 89 | HCNAME: ${{ matrix.compiler }} 90 | HCVER: ${{ matrix.compilerVersion }} 91 | - name: env 92 | run: | 93 | env 94 | - name: write cabal config 95 | run: | 96 | mkdir -p $CABAL_DIR 97 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 130 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 131 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 132 | rm -f cabal-plan.xz 133 | chmod a+x $HOME/.cabal/bin/cabal-plan 134 | cabal-plan --version 135 | - name: checkout 136 | uses: actions/checkout@v4 137 | with: 138 | path: source 139 | - name: initial cabal.project for sdist 140 | run: | 141 | touch cabal.project 142 | echo "packages: $GITHUB_WORKSPACE/source/ki" >> cabal.project 143 | echo "packages: $GITHUB_WORKSPACE/source/ki-unlifted" >> cabal.project 144 | cat cabal.project 145 | - name: sdist 146 | run: | 147 | mkdir -p sdist 148 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 149 | - name: unpack 150 | run: | 151 | mkdir -p unpacked 152 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 153 | - name: generate cabal.project 154 | run: | 155 | PKGDIR_ki="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/ki-[0-9.]*')" 156 | echo "PKGDIR_ki=${PKGDIR_ki}" >> "$GITHUB_ENV" 157 | PKGDIR_ki_unlifted="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/ki-unlifted-[0-9.]*')" 158 | echo "PKGDIR_ki_unlifted=${PKGDIR_ki_unlifted}" >> "$GITHUB_ENV" 159 | rm -f cabal.project cabal.project.local 160 | touch cabal.project 161 | touch cabal.project.local 162 | echo "packages: ${PKGDIR_ki}" >> cabal.project 163 | echo "packages: ${PKGDIR_ki_unlifted}" >> cabal.project 164 | echo "package ki" >> cabal.project 165 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 166 | echo "package ki-unlifted" >> cabal.project 167 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 168 | cat >> cabal.project <> cabal.project.local 171 | cat cabal.project 172 | cat cabal.project.local 173 | - name: dump install plan 174 | run: | 175 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 176 | cabal-plan 177 | - name: restore cache 178 | uses: actions/cache/restore@v4 179 | with: 180 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 181 | path: ~/.cabal/store 182 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 183 | - name: install dependencies 184 | run: | 185 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 186 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 187 | - name: build w/o tests 188 | run: | 189 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 190 | - name: build 191 | run: | 192 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 193 | - name: tests 194 | run: | 195 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 196 | - name: cabal check 197 | run: | 198 | cd ${PKGDIR_ki} || false 199 | ${CABAL} -vnormal check 200 | cd ${PKGDIR_ki_unlifted} || false 201 | ${CABAL} -vnormal check 202 | - name: haddock 203 | run: | 204 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 205 | - name: unconstrained build 206 | run: | 207 | rm -f cabal.project.local 208 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 209 | - name: save cache 210 | if: always() 211 | uses: actions/cache/save@v4 212 | with: 213 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 214 | path: ~/.cabal/store 215 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .envrc 2 | .ghc.environment.* 3 | .ghcid 4 | Session.vim 5 | dist-newstyle/ 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ki/README.md -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ki, ki-unlifted 2 | -------------------------------------------------------------------------------- /ki-unlifted/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## [1.0.0.2] - 2023-10-10 2 | 3 | - Compat: support GHC 9.8.1 4 | 5 | ## [1.0.0.1] - 2022-08-14 6 | 7 | - Compat: support GHC 9.4.1 8 | 9 | ## [1.0.0] - 2022-06-30 10 | 11 | - Initial release. 12 | -------------------------------------------------------------------------------- /ki-unlifted/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020-2025 Mitchell Rosen, Travis Staton 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | -------------------------------------------------------------------------------- /ki-unlifted/ki-unlifted.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | author: Mitchell Rosen 4 | bug-reports: https://github.com/awkward-squad/ki/issues 5 | category: Concurrency 6 | copyright: Copyright (C) 2020-2025 Mitchell Rosen, Travis Staton 7 | homepage: https://github.com/awkward-squad/ki 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | maintainer: Mitchell Rosen , Travis Staton 11 | name: ki-unlifted 12 | stability: stable 13 | synopsis: A lightweight structured concurrency library 14 | tested-with: GHC == 9.8.4, GHC == 9.10.1, GHC == 9.12.1 15 | version: 1.0.0.2 16 | x-revision: 3 17 | 18 | description: 19 | A lightweight structured concurrency library. 20 | . 21 | For a specialised variant of this API that does not use 22 | @@, see 23 | @@. 24 | 25 | extra-source-files: 26 | CHANGELOG.md 27 | 28 | source-repository head 29 | type: git 30 | location: https://github.com/awkward-squad/ki.git 31 | subdir: ki-unlifted 32 | 33 | common component 34 | build-depends: 35 | base ^>= 4.12 || ^>= 4.13 || ^>= 4.14 || ^>= 4.15 || ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19 || ^>= 4.20 || ^>= 4.21, 36 | default-extensions: 37 | AllowAmbiguousTypes 38 | BangPatterns 39 | BlockArguments 40 | ConstraintKinds 41 | DeriveAnyClass 42 | DeriveDataTypeable 43 | DeriveFunctor 44 | DeriveGeneric 45 | DerivingStrategies 46 | DuplicateRecordFields 47 | ExistentialQuantification 48 | GeneralizedNewtypeDeriving 49 | InstanceSigs 50 | LambdaCase 51 | NamedFieldPuns 52 | NoImplicitPrelude 53 | NumericUnderscores 54 | PartialTypeSignatures 55 | PatternSynonyms 56 | RankNTypes 57 | RoleAnnotations 58 | ScopedTypeVariables 59 | TypeApplications 60 | ViewPatterns 61 | default-language: Haskell2010 62 | ghc-options: 63 | -Weverything 64 | -Wno-all-missed-specialisations 65 | -Wno-implicit-prelude 66 | -Wno-missed-specialisations 67 | -Wno-missing-import-lists 68 | -Wno-safe 69 | -Wno-unsafe 70 | if impl(ghc >= 8.10) 71 | ghc-options: 72 | -Wno-missing-safe-haskell-mode 73 | -Wno-prepositive-qualified-module 74 | if impl(ghc >= 9.2) 75 | ghc-options: 76 | -Wno-missing-kind-signatures 77 | if impl(ghc >= 9.8) 78 | ghc-options: 79 | -Wno-missing-role-annotations 80 | 81 | library 82 | import: component 83 | build-depends: 84 | ki ^>= 1.0, 85 | unliftio-core ^>= 0.2, 86 | exposed-modules: 87 | Ki.Unlifted 88 | hs-source-dirs: src 89 | -------------------------------------------------------------------------------- /ki-unlifted/src/Ki/Unlifted.hs: -------------------------------------------------------------------------------- 1 | -- | The `ki` API, generalized to use 'MonadUnliftIO'. 2 | -- 3 | -- __Note__: See @[Ki](https://hackage.haskell.org/package/ki/docs/Ki.html)@ for the main module documentation. Any 4 | -- documentation you see here is incidental, and only a result of re-exporting symbols directly from 5 | -- @[Ki](https://hackage.haskell.org/package/ki/docs/Ki.html)@. 6 | module Ki.Unlifted 7 | ( Ki.Scope, 8 | Ki.Thread, 9 | scoped, 10 | fork, 11 | forkTry, 12 | Ki.await, 13 | Ki.awaitAll, 14 | fork_, 15 | forkWith, 16 | forkWith_, 17 | forkTryWith, 18 | Ki.ThreadOptions (..), 19 | Ki.defaultThreadOptions, 20 | Ki.ThreadAffinity (..), 21 | Ki.ByteCount, 22 | Ki.kilobytes, 23 | Ki.megabytes, 24 | ) 25 | where 26 | 27 | import Control.Exception (Exception) 28 | import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO)) 29 | import Data.Void (Void) 30 | import qualified Ki 31 | import Prelude 32 | 33 | fork :: forall a m. MonadUnliftIO m => Ki.Scope -> m a -> m (Ki.Thread a) 34 | fork scope action = 35 | withRunInIO \unlift -> Ki.fork scope (unlift action) 36 | 37 | fork_ :: MonadUnliftIO m => Ki.Scope -> m Void -> m () 38 | fork_ scope action = 39 | withRunInIO \unlift -> Ki.fork_ scope (unlift action) 40 | 41 | forkWith :: forall a m. MonadUnliftIO m => Ki.Scope -> Ki.ThreadOptions -> m a -> m (Ki.Thread a) 42 | forkWith scope opts action = 43 | withRunInIO \unlift -> Ki.forkWith scope opts (unlift action) 44 | 45 | forkWith_ :: MonadUnliftIO m => Ki.Scope -> Ki.ThreadOptions -> m Void -> m () 46 | forkWith_ scope opts action = 47 | withRunInIO \unlift -> Ki.forkWith_ scope opts (unlift action) 48 | 49 | forkTry :: (Exception e, MonadUnliftIO m) => Ki.Scope -> m a -> m (Ki.Thread (Either e a)) 50 | forkTry scope action = 51 | withRunInIO \unlift -> Ki.forkTry scope (unlift action) 52 | 53 | forkTryWith :: 54 | (Exception e, MonadUnliftIO m) => 55 | Ki.Scope -> 56 | Ki.ThreadOptions -> 57 | m a -> 58 | m (Ki.Thread (Either e a)) 59 | forkTryWith scope opts action = 60 | withRunInIO \unlift -> Ki.forkTryWith scope opts (unlift action) 61 | 62 | scoped :: forall a m. MonadUnliftIO m => (Ki.Scope -> m a) -> m a 63 | scoped action = 64 | withRunInIO \unlift -> Ki.scoped \scope -> unlift (action scope) 65 | -------------------------------------------------------------------------------- /ki/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## [1.0.1.2] - July 15, 2024 2 | 3 | - Bugfix [#33](https://github.com/awkward-squad/ki/issues/33): A scope could erroneously fail to propagate an exception 4 | to one of its children. 5 | - Refactor: depend on (rather than inline) `int-supply` package. 6 | 7 | ## [1.0.1.1] - October 10, 2023 8 | 9 | - Compat: support GHC 9.8.1 10 | 11 | ## [1.0.1.0] - April 3, 2023 12 | 13 | - Change [#25](https://github.com/awkward-squad/ki/pull/25): Attempting to fork a thread in a closing scope now acts as 14 | if it were a child being terminated due to the scope closing. Previously, attempting to fork a thread in a closing 15 | scope would throw a runtime exception like `error "ki: scope closed"`. 16 | - Change [#27](https://github.com/awkward-squad/ki/pull/27): Calling `awaitAll` on a closed scope now returns `()` 17 | instead of blocking forever. 18 | 19 | ## [1.0.0.2] - January 25, 2023 20 | 21 | - Bugfix [#20](https://github.com/awkward-squad/ki/pull/20): previously, a child thread could deadlock when attempting 22 | to propagate an exception to its parent. 23 | 24 | ## [1.0.0.1] - August 14, 2022 25 | 26 | - Compat: support GHC 9.4.1 27 | 28 | ## [1.0.0] - June 30, 2022 29 | 30 | - Breaking: Remove `Context` type, `Ki.Implicit` module, and the ability to soft-cancel a `Scope`. 31 | - Breaking: Remove `Duration` type and its associated API, including `waitFor` and `awaitFor`. 32 | - Breaking: Remove `Ki.Internal` module. 33 | - Breaking: Generalize `async` to `forkTry`. 34 | - Breaking: Generalize `forkWithUnmask` to `forkWith`. 35 | - Breaking: Make `fork_` take an `IO Void` rather than an `IO ()`. 36 | - Breaking: Make `fork` create an unmasked thread, rather than inherit the parent's masking state. 37 | - Breaking: Rename `waitSTM` to `awaitAll` (replacing the old `wait` in `IO`). 38 | 39 | - Change: Make `scoped` kill threads in the order they were created. 40 | 41 | - Bugfix: Fix small memory leak related to closing a scope. 42 | - Bugfix: Fix subtle bug related to GHC's treatment of deadlocked threads. 43 | - Bugfix: make `async` (now `forkTry`) propagate async exceptions. 44 | - Bugfix: make `scoped` safe to run with asynchronous exceptions masked. 45 | - Bugfix: propagate exceptions to creator of scope, not creator of thread 46 | 47 | - Performance: Use atomic fetch-and-add rather than a `TVar` to track internal child thread ids. 48 | 49 | ## [0.2.0] - December 17, 2020 50 | 51 | - Breaking: Remove `ThreadFailed` exception wrapper. 52 | - Breaking: Rename `cancelScope` to `cancel`. 53 | 54 | ## [0.1.0.1] - November 30, 2020 55 | 56 | - Misc: Replace `AtomicCounter` with `Int` to drop the `atomic-primops` dependency. 57 | 58 | - Bounds: Lower `cabal-version` from 3.0 to 2.2 because `stack` cannot parse 3.0. 59 | 60 | ## [0.1.0] - November 11, 2020 61 | 62 | - Initial release. 63 | -------------------------------------------------------------------------------- /ki/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020-2025 Mitchell Dalvi Rosen, Travis Staton 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | -------------------------------------------------------------------------------- /ki/README.md: -------------------------------------------------------------------------------- 1 | | `ki` | `ki-unlifted` | 2 | | --- | --- | 3 | | [![GitHub CI](https://github.com/awkward-squad/ki/workflows/Haskell-CI/badge.svg)](https://github.com/awkward-squad/ki/actions) | | 4 | | [![Hackage](https://img.shields.io/hackage/v/ki.svg?label=ki&logo=haskell)](https://hackage.haskell.org/package/ki) | [![Hackage](https://img.shields.io/hackage/v/ki-unlifted.svg?label=ki-unlifted&logo=haskell)](https://hackage.haskell.org/package/ki-unlifted) | 5 | | [![Stackage LTS](https://stackage.org/package/ki/badge/lts)](https://www.stackage.org/lts/package/ki) | [![Stackage LTS](https://stackage.org/package/ki-unlifted/badge/lts)](https://www.stackage.org/lts/package/ki-unlifted) | 6 | | [![Stackage Nightly](https://stackage.org/package/ki/badge/nightly)](https://www.stackage.org/nightly/package/ki) | [![Stackage Nightly](https://stackage.org/package/ki-unlifted/badge/nightly)](https://www.stackage.org/nightly/package/ki-unlifted) | 7 | | [![Dependencies](https://img.shields.io/hackage-deps/v/ki)](https://packdeps.haskellers.com/reverse/ki) | [![Dependencies](https://img.shields.io/hackage-deps/v/ki-unlifted)](https://packdeps.haskellers.com/reverse/ki-unlifted) | 8 | 9 | # Overview 10 | 11 | `ki` is a lightweight structured-concurrency library inspired by many other projects and blog posts: 12 | 13 | * [libdill](http://libdill.org/) 14 | * [trio](https://github.com/python-trio/trio) 15 | * [Kotlin coroutines](https://kotlinlang.org/docs/reference/coroutines-overview.html) 16 | * [Notes on structured concurrency, or: Go statement considered harmful](https://vorpus.org/blog/notes-on-structured-concurrency-or-go-statement-considered-harmful) 17 | * [Structured Concurrency in High-level Languages](https://250bpm.com/blog:124) 18 | * [Update on Structured Concurrency](https://250bpm.com/blog:137) 19 | * [Two Approaches to Structured Concurrency](https://250bpm.com/blog:139) 20 | * [libdill: Structured Concurrency for C](https://libdill.org/structured-concurrency.html) 21 | 22 | A previous version of `ki` also included a mechanism for soft-cancellation/graceful shutdown, which took inspiration 23 | from: 24 | 25 | * [Go Concurrency Patterns: Context](https://blog.golang.org/context) 26 | * [.NET 4 Cancellation Framework](https://devblogs.microsoft.com/pfxteam/net-4-cancellation-framework) 27 | * [Timeouts and cancellation for humans](https://vorpus.org/blog/timeouts-and-cancellation-for-humans) 28 | * [Graceful Shutdown](https://250bpm.com/blog:146) 29 | 30 | However, this feature was removed (perhaps temporarily) because the design of the API was unsatisfactory. 31 | 32 | # Documentation 33 | 34 | [Hackage documentation](https://hackage.haskell.org/package/ki/docs/Ki.html) 35 | 36 | # Example: Happy Eyeballs 37 | 38 | The [Happy Eyeballs](https://en.wikipedia.org/wiki/Happy_Eyeballs) algorithm is a particularly common example used to 39 | demonstrate the advantages of structured concurrency, because it is simple to describe, but can be surprisingly 40 | difficult to implement. 41 | 42 | The problem can be abstractly described as follows: we have a small set of actions to run, each of which can take 43 | arbitrarily long, or fail. Each action is a different way of computing the same value, so we only need to wait for 44 | one action to return successfully. We don't want to run the actions one at a time (because that is likely to take too 45 | long), nor all at once (because that is an improper use of resources). Rather, we will begin executing the first action, 46 | then wait 250 milliseconds, then begin executing the second, and so on, until one returns successfully. 47 | 48 | There are of course a number of ways to implement this algorithm. We'll do something non-optimal, but simple. Let's get 49 | the imports out of the way first. 50 | 51 | ```haskell 52 | import Control.Concurrent 53 | import Control.Monad (when) 54 | import Control.Monad.STM (atomically) 55 | import Data.Function ((&)) 56 | import Data.Functor (void) 57 | import Data.List qualified as List 58 | import Data.Maybe (isJust) 59 | import Ki qualified 60 | ``` 61 | 62 | Next, let's define a `staggeredSpawner` helper that implements the majority of the core algorithm: given a list of 63 | actions, spawn them all at 250 millisecond intervals. After all actions are spawned, we block until all of them have 64 | returned. 65 | 66 | ```haskell 67 | staggeredSpawner :: [IO ()] -> IO () 68 | staggeredSpawner actions = do 69 | Ki.scoped \scope -> do 70 | actions 71 | & map (\action -> void (Ki.fork scope action)) 72 | & List.intersperse (threadDelay 250_000) 73 | & sequence_ 74 | atomically (Ki.awaitAll scope) 75 | ``` 76 | 77 | And finally, we wrap this helper with `happyEyeballs`, which accepts a list of actions, and returns when one action 78 | returns successfully, or returns `Nothing` if all actions fail. Note that in a real implementation, we may want to 79 | consider what to do if an action throws an exception. Here, we trust each action to signal failure by returning 80 | `Nothing`. 81 | 82 | ```haskell 83 | happyEyeballs :: [IO (Maybe a)] -> IO (Maybe a) 84 | happyEyeballs actions = do 85 | resultVar <- newEmptyMVar 86 | 87 | let worker action = do 88 | result <- action 89 | when (isJust result) do 90 | _ <- tryPutMVar resultVar result 91 | pure () 92 | 93 | Ki.scoped \scope -> do 94 | _ <- 95 | Ki.fork scope do 96 | staggeredSpawner (map worker actions) 97 | tryPutMVar resultVar Nothing 98 | takeMVar resultVar 99 | ``` 100 | -------------------------------------------------------------------------------- /ki/ki.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | author: Mitchell Dalvi Rosen, Travis Staton 4 | bug-reports: https://github.com/awkward-squad/ki/issues 5 | category: Concurrency 6 | copyright: Copyright (C) 2020-2025 Mitchell Dalvi Rosen, Travis Staton 7 | homepage: https://github.com/awkward-squad/ki 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | maintainer: Mitchell Dalvi Rosen , Travis Staton 11 | name: ki 12 | stability: stable 13 | synopsis: A lightweight structured concurrency library 14 | tested-with: GHC == 9.8.4, GHC == 9.10.1, GHC == 9.12.1 15 | version: 1.0.1.2 16 | x-revision: 2 17 | 18 | description: 19 | A lightweight structured concurrency library. 20 | . 21 | For a variant of this API generalized to 22 | @@, 23 | see @@. 24 | . 25 | Remember to link your program with @-threaded@ to use the threaded runtime! 26 | 27 | extra-doc-files: 28 | CHANGELOG.md 29 | README.md 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/awkward-squad/ki.git 34 | subdir: ki 35 | 36 | common component 37 | build-depends: 38 | base ^>= 4.12 || ^>= 4.13 || ^>= 4.14 || ^>= 4.15 || ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19 || ^>= 4.20 || ^>= 4.21, 39 | default-extensions: 40 | AllowAmbiguousTypes 41 | BangPatterns 42 | BlockArguments 43 | ConstraintKinds 44 | DeriveAnyClass 45 | DeriveDataTypeable 46 | DeriveFunctor 47 | DeriveGeneric 48 | DerivingStrategies 49 | DuplicateRecordFields 50 | ExistentialQuantification 51 | GeneralizedNewtypeDeriving 52 | InstanceSigs 53 | LambdaCase 54 | NamedFieldPuns 55 | NumericUnderscores 56 | PartialTypeSignatures 57 | PatternSynonyms 58 | RankNTypes 59 | RoleAnnotations 60 | ScopedTypeVariables 61 | TypeApplications 62 | ViewPatterns 63 | default-language: Haskell2010 64 | ghc-options: 65 | -Weverything 66 | -Wno-all-missed-specialisations 67 | -Wno-implicit-prelude 68 | -Wno-missed-specialisations 69 | -Wno-missing-import-lists 70 | -Wno-safe 71 | -Wno-unsafe 72 | if impl(ghc >= 8.10) 73 | ghc-options: 74 | -Wno-missing-safe-haskell-mode 75 | -Wno-prepositive-qualified-module 76 | if impl(ghc >= 9.2) 77 | ghc-options: 78 | -Wno-missing-kind-signatures 79 | if impl(ghc >= 9.8) 80 | ghc-options: 81 | -Wno-missing-role-annotations 82 | 83 | library 84 | import: component 85 | build-depends: 86 | containers ^>= 0.6 || ^>= 0.7 || ^>= 0.8, 87 | int-supply ^>= 1.0.0, 88 | exposed-modules: 89 | Ki 90 | hs-source-dirs: src 91 | other-modules: 92 | Ki.Internal.ByteCount 93 | Ki.Internal.IO 94 | Ki.Internal.NonblockingSTM 95 | Ki.Internal.Propagating 96 | Ki.Internal.Scope 97 | Ki.Internal.Thread 98 | Ki.Internal.ThreadAffinity 99 | Ki.Internal.ThreadOptions 100 | 101 | test-suite tests 102 | import: component 103 | build-depends: 104 | ki, 105 | stm ^>= 2.5, 106 | tasty ^>= 1.4.2 || ^>= 1.5, 107 | tasty-hunit ^>= 0.10, 108 | ghc-options: -rtsopts -threaded 109 | hs-source-dirs: test 110 | main-is: Tests.hs 111 | type: exitcode-stdio-1.0 112 | -------------------------------------------------------------------------------- /ki/src/Ki.hs: -------------------------------------------------------------------------------- 1 | -- | `ki` is a lightweight structured concurrency library. 2 | -- 3 | -- For a variant of this API generalized to 4 | -- @@, 5 | -- see @@. 6 | -- 7 | -- Remember to link your program with @-threaded@ to use the threaded runtime! 8 | module Ki 9 | ( -- * Introduction 10 | -- $introduction 11 | 12 | -- * Core API 13 | Scope, 14 | Thread, 15 | scoped, 16 | fork, 17 | forkTry, 18 | await, 19 | awaitAll, 20 | 21 | -- * Extended API 22 | fork_, 23 | forkWith, 24 | forkWith_, 25 | forkTryWith, 26 | 27 | -- ** Thread options 28 | ThreadOptions (..), 29 | defaultThreadOptions, 30 | ThreadAffinity (..), 31 | 32 | -- ** Byte count 33 | ByteCount, 34 | kilobytes, 35 | megabytes, 36 | ) 37 | where 38 | 39 | import Ki.Internal.ByteCount (ByteCount, kilobytes, megabytes) 40 | import Ki.Internal.Scope 41 | ( Scope, 42 | awaitAll, 43 | fork, 44 | forkTry, 45 | forkTryWith, 46 | forkWith, 47 | forkWith_, 48 | fork_, 49 | scoped, 50 | ) 51 | import Ki.Internal.Thread (Thread, await) 52 | import Ki.Internal.ThreadAffinity (ThreadAffinity (..)) 53 | import Ki.Internal.ThreadOptions (ThreadOptions (..), defaultThreadOptions) 54 | 55 | -- $introduction 56 | -- 57 | -- Structured concurrency is a paradigm of concurrent programming in which a lexical scope delimits the lifetime of each 58 | -- thread. Threads therefore form a "call tree" hierarchy in which no child can outlive its parent. 59 | -- 60 | -- Exceptions are propagated promptly from child to parent and vice-versa: 61 | -- 62 | -- * If an exception is raised in a child thread, the child raises the same exception in its parent, then 63 | -- terminates. 64 | -- 65 | -- * If an exception is raised in a parent thread, the parent first raises an exception in all of its living 66 | -- children, waits for them to terminate, then re-raises the original exception. 67 | -- 68 | -- All together, this library: 69 | -- 70 | -- * Guarantees the absence of "ghost threads" (/i.e./ threads that accidentally continue to run alongside the main 71 | -- thread after the function that spawned them returns). 72 | -- 73 | -- * Performs prompt, bidirectional exception propagation when an exception is raised anywhere in the call tree. 74 | -- 75 | -- * Provides a safe and flexible API that can be used directly, or with which higher-level concurrency patterns can 76 | -- be built on top, such as worker queues, pub-sub pipelines, and supervision trees. 77 | -- 78 | -- For a longer introduction to structured concurrency, including an educative analogy to structured programming, please 79 | -- read Nathaniel J. Smith's blog post, 80 | -- . 81 | -- 82 | -- ==== __👉 Quick start examples__ 83 | -- 84 | -- * Perform two actions concurrently, and wait for both of them to complete. 85 | -- 86 | -- @ 87 | -- concurrently :: IO a -> IO b -> IO (a, b) 88 | -- concurrently action1 action2 = 89 | -- Ki.'Ki.scoped' \\scope -> do 90 | -- thread1 <- Ki.'Ki.fork' scope action1 91 | -- result2 <- action2 92 | -- result1 <- atomically (Ki.'Ki.await' thread1) 93 | -- pure (result1, result2) 94 | -- @ 95 | -- 96 | -- * Perform two actions concurrently, and when the first action terminates, stop executing the other. 97 | -- 98 | -- @ 99 | -- race :: IO a -> IO a -> IO a 100 | -- race action1 action2 = 101 | -- Ki.'Ki.scoped' \\scope -> do 102 | -- resultVar \<- newEmptyMVar 103 | -- _ \<- Ki.'Ki.fork' scope (action1 \>>= tryPutMVar resultVar) 104 | -- _ \<- Ki.'Ki.fork' scope (action2 \>>= tryPutMVar resultVar) 105 | -- takeMVar resultVar 106 | -- @ 107 | -------------------------------------------------------------------------------- /ki/src/Ki/Internal/ByteCount.hs: -------------------------------------------------------------------------------- 1 | module Ki.Internal.ByteCount 2 | ( ByteCount, 3 | kilobytes, 4 | megabytes, 5 | byteCountToInt64, 6 | ) 7 | where 8 | 9 | import Data.Coerce (coerce) 10 | import Data.Int (Int64) 11 | import Numeric.Natural (Natural) 12 | 13 | -- | A number of bytes. 14 | newtype ByteCount = ByteCount Int64 15 | deriving newtype (Eq, Ord) 16 | 17 | instance Show ByteCount where 18 | show (ByteCount b) 19 | | (mb, 0) <- quotRem b 1048576, mb > 0 = "megabytes " ++ show mb 20 | | (kb, 0) <- quotRem b 1024 = "kilobytes " ++ show kb 21 | | otherwise = undefined 22 | 23 | -- | A number of kilobytes. 24 | kilobytes :: Natural -> ByteCount 25 | kilobytes n = 26 | ByteCount (snip (n * 1024)) 27 | 28 | -- | A number of megabytes. 29 | megabytes :: Natural -> ByteCount 30 | megabytes n = 31 | ByteCount (snip (n * 1048576)) 32 | 33 | byteCountToInt64 :: ByteCount -> Int64 34 | byteCountToInt64 = 35 | coerce 36 | 37 | snip :: Natural -> Int64 38 | snip n = 39 | fromIntegral (min (fromIntegral (maxBound :: Int64)) n) 40 | -------------------------------------------------------------------------------- /ki/src/Ki/Internal/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | 4 | -- | Miscellaneous IO utilities 5 | module Ki.Internal.IO 6 | ( -- * Unexceptional IO 7 | UnexceptionalIO (..), 8 | IOResult (..), 9 | unexceptionalTry, 10 | unexceptionalTryEither, 11 | 12 | -- * Exception utils 13 | assertIO, 14 | assertM, 15 | exceptionIs, 16 | interruptiblyMasked, 17 | uninterruptiblyMasked, 18 | tryEitherSTM, 19 | 20 | -- * Fork utils 21 | forkIO, 22 | forkOn, 23 | ) 24 | where 25 | 26 | import Control.Exception 27 | import Control.Monad (join) 28 | import Data.Coerce (coerce) 29 | import Data.Maybe (isJust) 30 | import GHC.Base (maskAsyncExceptions#, maskUninterruptible#) 31 | import GHC.Conc (STM, ThreadId (ThreadId), catchSTM) 32 | import GHC.Exts (Int (I#), fork#, forkOn#) 33 | import GHC.IO (IO (IO)) 34 | import System.IO.Unsafe (unsafePerformIO) 35 | import Prelude 36 | 37 | -- A little promise that this IO action cannot throw an exception (*including* async exceptions, which you normally 38 | -- think of as being able to strike at any time). 39 | -- 40 | -- Yeah it's verbose, and maybe not that necessary, but the code that bothers to use it really does require 41 | -- un-exceptiony IO actions for correctness, so here we are. 42 | newtype UnexceptionalIO a = UnexceptionalIO 43 | {runUnexceptionalIO :: IO a} 44 | deriving newtype (Applicative, Functor, Monad) 45 | 46 | data IOResult a 47 | = Failure !SomeException -- sync or async exception 48 | | Success a 49 | 50 | -- Try an action, catching any exception it throws. 51 | -- 52 | -- The caller is responsible for ensuring that async exceptions are masked (at whatever masking level is appropriate), 53 | -- as (again) `UnexceptionalIO` implies async exceptions won't be thrown either. 54 | unexceptionalTry :: forall a. IO a -> UnexceptionalIO (IOResult a) 55 | unexceptionalTry action = 56 | UnexceptionalIO do 57 | (Success <$> action) `catch` \exception -> 58 | pure (Failure exception) 59 | 60 | -- Like try, but with continuations. 61 | unexceptionalTryEither :: 62 | forall a b. 63 | (SomeException -> UnexceptionalIO b) -> 64 | (a -> UnexceptionalIO b) -> 65 | IO a -> 66 | UnexceptionalIO b 67 | unexceptionalTryEither onFailure onSuccess action = 68 | UnexceptionalIO do 69 | join do 70 | catch 71 | (coerce @_ @(a -> IO b) onSuccess <$> action) 72 | (pure . coerce @_ @(SomeException -> IO b) onFailure) 73 | 74 | -- | Make an assertion in a IO that requires IO. 75 | assertIO :: IO Bool -> IO () 76 | assertIO b = 77 | assert (unsafePerformIO b) (pure ()) 78 | {-# INLINE assertIO #-} 79 | 80 | -- | Make an assertion in a monad. 81 | assertM :: (Applicative m) => Bool -> m () 82 | assertM b = 83 | assert b (pure ()) 84 | {-# INLINE assertM #-} 85 | 86 | -- | @exceptionIs \@e exception@ returns whether @exception@ is an instance of @e@. 87 | exceptionIs :: forall e. (Exception e) => SomeException -> Bool 88 | exceptionIs = 89 | isJust . fromException @e 90 | 91 | -- | Call an action with asynchronous exceptions interruptibly masked. 92 | interruptiblyMasked :: forall a. IO a -> IO a 93 | interruptiblyMasked = 94 | coerce (maskAsyncExceptions# @a) 95 | 96 | -- | Call an action with asynchronous exceptions uninterruptibly masked. 97 | uninterruptiblyMasked :: forall a. IO a -> IO a 98 | uninterruptiblyMasked = 99 | coerce (maskUninterruptible# @a) 100 | 101 | -- Like try, but with continuations 102 | tryEitherSTM :: (Exception e) => (e -> STM b) -> (a -> STM b) -> STM a -> STM b 103 | tryEitherSTM onFailure onSuccess action = 104 | join (catchSTM (onSuccess <$> action) (pure . onFailure)) 105 | 106 | -- Control.Concurrent.forkIO without the exception handler 107 | forkIO :: IO () -> IO ThreadId 108 | forkIO (IO action) = 109 | IO \s0 -> 110 | case fork# action s0 of 111 | (# s1, tid #) -> (# s1, ThreadId tid #) 112 | 113 | -- Control.Concurrent.forkOn without the exception handler 114 | forkOn :: Int -> IO () -> IO ThreadId 115 | forkOn (I# cap) (IO action) = 116 | IO \s0 -> 117 | case forkOn# cap action s0 of 118 | (# s1, tid #) -> (# s1, ThreadId tid #) 119 | -------------------------------------------------------------------------------- /ki/src/Ki/Internal/NonblockingSTM.hs: -------------------------------------------------------------------------------- 1 | -- | STM minus retry. These STM actions are guaranteed not to block, and thus guaranteed not to be interrupted by an 2 | -- async exception. 3 | module Ki.Internal.NonblockingSTM 4 | ( NonblockingSTM, 5 | nonblockingAtomically, 6 | nonblockingThrowSTM, 7 | 8 | -- * TVar 9 | nonblockingReadTVar, 10 | nonblockingWriteTVar', 11 | ) 12 | where 13 | 14 | import Control.Exception (Exception) 15 | import Data.Coerce (coerce) 16 | import GHC.Conc (STM, TVar, atomically, readTVar, throwSTM, writeTVar) 17 | 18 | newtype NonblockingSTM a 19 | = NonblockingSTM (STM a) 20 | deriving newtype (Applicative, Functor, Monad) 21 | 22 | nonblockingAtomically :: forall a. NonblockingSTM a -> IO a 23 | nonblockingAtomically = 24 | coerce @(STM a -> IO a) atomically 25 | 26 | nonblockingThrowSTM :: forall e x. (Exception e) => e -> NonblockingSTM x 27 | nonblockingThrowSTM = 28 | coerce @(e -> STM x) throwSTM 29 | 30 | nonblockingReadTVar :: forall a. TVar a -> NonblockingSTM a 31 | nonblockingReadTVar = 32 | coerce @(TVar a -> STM a) readTVar 33 | 34 | nonblockingWriteTVar' :: forall a. TVar a -> a -> NonblockingSTM () 35 | nonblockingWriteTVar' var !x = 36 | NonblockingSTM (writeTVar var x) 37 | -------------------------------------------------------------------------------- /ki/src/Ki/Internal/Propagating.hs: -------------------------------------------------------------------------------- 1 | module Ki.Internal.Propagating 2 | ( Tid, 3 | peelOffPropagating, 4 | propagate, 5 | ) 6 | where 7 | 8 | import Control.Concurrent (ThreadId) 9 | import Control.Exception (Exception (..), SomeException, asyncExceptionFromException, asyncExceptionToException, throwTo) 10 | 11 | -- Internal exception type thrown by a child thread to its parent, if the child fails unexpectedly. 12 | data Propagating = Propagating 13 | { childId :: {-# UNPACK #-} !Tid, 14 | exception :: !SomeException 15 | } 16 | 17 | instance Exception Propagating where 18 | toException = asyncExceptionToException 19 | fromException = asyncExceptionFromException 20 | 21 | instance Show Propagating where 22 | show _ = "<>" 23 | 24 | pattern PropagatingThe :: SomeException -> SomeException 25 | pattern PropagatingThe exception <- (fromException -> Just Propagating {exception}) 26 | 27 | -- A unique identifier for a thread within a scope. (Internal type alias) 28 | type Tid = 29 | Int 30 | 31 | -- Peel an outer Propagating layer off of some exception, if there is one. 32 | peelOffPropagating :: SomeException -> SomeException 33 | peelOffPropagating = \case 34 | PropagatingThe exception -> exception 35 | exception -> exception 36 | 37 | -- @propagate exception child parent@ propagates @exception@ from @child@ to @parent@. 38 | propagate :: SomeException -> Tid -> ThreadId -> IO () 39 | propagate exception childId parentThreadId = 40 | throwTo parentThreadId Propagating {childId, exception} 41 | -------------------------------------------------------------------------------- /ki/src/Ki/Internal/Scope.hs: -------------------------------------------------------------------------------- 1 | module Ki.Internal.Scope 2 | ( Scope, 3 | scoped, 4 | awaitAll, 5 | fork, 6 | forkWith, 7 | forkWith_, 8 | fork_, 9 | forkTry, 10 | forkTryWith, 11 | ) 12 | where 13 | 14 | import Control.Concurrent (ThreadId, myThreadId, throwTo) 15 | import Control.Concurrent.MVar (MVar, newEmptyMVar, tryPutMVar, tryTakeMVar) 16 | import Control.Exception 17 | ( Exception (fromException, toException), 18 | MaskingState (..), 19 | SomeAsyncException, 20 | SomeException, 21 | asyncExceptionFromException, 22 | asyncExceptionToException, 23 | throwIO, 24 | try, 25 | uninterruptibleMask, 26 | pattern ErrorCall, 27 | ) 28 | import Control.Monad (guard, when) 29 | import Data.Foldable (for_) 30 | import Data.Functor (void) 31 | import Data.IntMap (IntMap) 32 | import qualified Data.IntMap.Lazy as IntMap.Lazy 33 | import Data.Void (Void, absurd) 34 | import GHC.Conc 35 | ( STM, 36 | TVar, 37 | atomically, 38 | enableAllocationLimit, 39 | labelThread, 40 | newTVarIO, 41 | readTVar, 42 | retry, 43 | setAllocationCounter, 44 | throwSTM, 45 | writeTVar, 46 | ) 47 | import GHC.Conc.Sync (readTVarIO) 48 | import GHC.IO (unsafeUnmask) 49 | import IntSupply (IntSupply) 50 | import qualified IntSupply 51 | import Ki.Internal.ByteCount (byteCountToInt64) 52 | import Ki.Internal.IO 53 | ( IOResult (..), 54 | UnexceptionalIO (..), 55 | assertM, 56 | exceptionIs, 57 | interruptiblyMasked, 58 | unexceptionalTry, 59 | unexceptionalTryEither, 60 | uninterruptiblyMasked, 61 | ) 62 | import Ki.Internal.NonblockingSTM 63 | import Ki.Internal.Propagating (Tid, peelOffPropagating, propagate) 64 | import Ki.Internal.Thread (Thread, makeThread) 65 | import Ki.Internal.ThreadAffinity (forkWithAffinity) 66 | import Ki.Internal.ThreadOptions (ThreadOptions (..), defaultThreadOptions) 67 | 68 | -- | A scope. 69 | -- 70 | -- ==== __👉 Details__ 71 | -- 72 | -- * A scope delimits the lifetime of all threads created within it. 73 | -- 74 | -- * A scope is only valid during the callback provided to 'Ki.scoped'. 75 | -- 76 | -- * The thread that creates a scope is considered the parent of all threads created within it. 77 | -- 78 | -- * All threads created within a scope can be awaited together (see 'Ki.awaitAll'). 79 | -- 80 | -- * All threads created within a scope are terminated when the scope closes. 81 | data Scope = Scope 82 | { -- The MVar that a child tries to put to, in the case that it tries to propagate an exception to its parent, but 83 | -- gets delivered an exception from its parent concurrently (which interrupts the throw). The parent must raise 84 | -- exceptions in its children with asynchronous exceptions uninterruptibly masked for correctness, yet we don't want 85 | -- a parent in the process of tearing down to miss/ignore this exception that we're trying to propagate? 86 | -- 87 | -- Why a single-celled MVar? What if two siblings are fighting to inform their parent of their death? Well, only 88 | -- one exception can be propagated by the parent anyway, so we wouldn't need or want both. 89 | childExceptionVar :: {-# UNPACK #-} !(MVar SomeException), 90 | -- The set of child threads that are currently running, each keyed by a monotonically increasing int. 91 | childrenVar :: {-# UNPACK #-} !(TVar (IntMap ThreadId)), 92 | -- The supply that holds the (int) key to use for the next child thread. 93 | nextChildIdSupply :: {-# UNPACK #-} !IntSupply, 94 | -- The id of the thread that created the scope, which is considered the parent of all threads created within it. 95 | parentThreadId :: {-# UNPACK #-} !ThreadId, 96 | statusVar :: {-# UNPACK #-} !(TVar ScopeStatus) 97 | } 98 | 99 | -- The scope status: either open (allowing new threads to be created), closing (disallowing new threads to be 100 | -- created, and in the process of killing running children), or closed (at the very end of `scoped`) 101 | type ScopeStatus = Int 102 | 103 | -- The number of child threads that are guaranteed to be about to start, in the sense that only the GHC scheduler 104 | -- can continue to delay; there's no opportunity for an async exception to strike and prevent one of these threads 105 | -- from starting. 106 | pattern Open :: Int 107 | pattern Open <- ((>= 0) -> True) 108 | 109 | -- The scope is closing. 110 | pattern Closing :: Int 111 | pattern Closing = -1 112 | 113 | -- The scope is closed. 114 | pattern Closed :: Int 115 | pattern Closed = -2 116 | 117 | {-# COMPLETE Open, Closing, Closed #-} 118 | 119 | -- Internal async exception thrown by a parent thread to its children when the scope is closing. 120 | -- 121 | -- In various places we trust without verifying that any 'ScopeClosing' exception, which is not exported by this module, 122 | -- was indeed thrown to a thread by its parent. It is possible to write a program that violates this (just catch the 123 | -- async exception and throw it to some other thread)... but who would do that? 124 | data ScopeClosing 125 | = ScopeClosing 126 | 127 | instance Show ScopeClosing where 128 | show _ = "<>" 129 | 130 | instance Exception ScopeClosing where 131 | toException = asyncExceptionToException 132 | fromException = asyncExceptionFromException 133 | 134 | -- | Open a scope, perform an IO action with it, then close the scope. 135 | -- 136 | -- ==== __👉 Details__ 137 | -- 138 | -- * The thread that creates a scope is considered the parent of all threads created within it. 139 | -- 140 | -- * A scope is only valid during the callback provided to 'Ki.scoped'. 141 | -- 142 | -- * When a scope closes (/i.e./ just before 'Ki.scoped' returns): 143 | -- 144 | -- * The parent thread raises an exception in all of its living children. 145 | -- * The parent thread blocks until those threads terminate. 146 | scoped :: (Scope -> IO a) -> IO a 147 | scoped action = do 148 | scope@Scope {childExceptionVar, childrenVar, statusVar} <- allocateScope 149 | 150 | uninterruptibleMask \restore -> do 151 | result <- try (restore (action scope)) 152 | 153 | !runningChildren <- do 154 | atomically do 155 | -- Block until we haven't committed to starting any threads. Without this, we may create a thread concurrently 156 | -- with closing its scope, and not grab its thread id to throw an exception to. 157 | starting <- readTVar statusVar 158 | assertM (starting >= 0) 159 | guard (starting == 0) 160 | -- Indicate that this scope is closing, so attempts to create a new thread within it will throw ScopeClosing 161 | -- (as if the calling thread was a parent of this scope, which it should be, and we threw it a ScopeClosing 162 | -- ourselves). 163 | writeTVar statusVar Closing 164 | -- Return the list of currently-running children to kill. Some of them may have *just* started (e.g. if we 165 | -- initially retried in `guard (n == 0)` above). That's fine - kill them all! 166 | readTVar childrenVar 167 | 168 | -- Deliver a ScopeClosing exception to every running child. 169 | -- 170 | -- This happens to throw in the order the children were created, but that isn't an important/useful enough feature 171 | -- to be worth documenting, so users shouldn't rely on it. It's definitely not the case that child 1 will completely 172 | -- terminate before child 2 is delivered an exception: each child may delay arbitrarily while cleaning up. 173 | for_ runningChildren \child -> throwTo child ScopeClosing 174 | 175 | atomically do 176 | -- Block until all children have terminated; this relies on children respecting the async exception, which they 177 | -- must, for correctness. Otherwise, a thread could indeed outlive the scope in which it's created, which is 178 | -- definitely not structured concurrency! 179 | children <- readTVar childrenVar 180 | guard (IntMap.Lazy.null children) 181 | 182 | -- Record the scope as closed (from closing), so subsequent attempts to use it will throw a runtime exception 183 | writeTVar statusVar Closed 184 | 185 | -- By now there are three sources of exception: 186 | -- 187 | -- 1) A sync or async exception thrown during the callback, captured in `result`. If applicable, we want to peel 188 | -- the `Propagating` off of this, which was only used to indicate it came from one of our children. 189 | -- 190 | -- 2) A sync or async exception left for us in `childExceptionVar` by a child that tried to propagate it to us 191 | -- directly, but failed (because we killed it concurrently). 192 | -- 193 | -- 3) An async exception waiting in our exception queue, because we still have async exceptions uninterruptibly 194 | -- masked. 195 | -- 196 | -- We cannot throw more than one, so throw them in that priority order. 197 | case result of 198 | Left exception -> throwIO (peelOffPropagating exception) 199 | Right value -> 200 | tryTakeMVar childExceptionVar >>= \case 201 | Nothing -> pure value 202 | Just exception -> throwIO exception 203 | 204 | -- Allocate a new scope. 205 | allocateScope :: IO Scope 206 | allocateScope = do 207 | childExceptionVar <- newEmptyMVar 208 | childrenVar <- newTVarIO IntMap.Lazy.empty 209 | nextChildIdSupply <- IntSupply.new 210 | parentThreadId <- myThreadId 211 | statusVar <- newTVarIO 0 212 | pure Scope {childExceptionVar, childrenVar, nextChildIdSupply, parentThreadId, statusVar} 213 | 214 | -- Spawn a thread in a scope, providing it its child id and a function that sets the masking state to the requested 215 | -- masking state. The given action is called with async exceptions interruptibly masked. 216 | spawn :: Scope -> ThreadOptions -> (Tid -> (forall x. IO x -> IO x) -> UnexceptionalIO ()) -> IO ChildIds 217 | spawn scope@Scope {childrenVar, statusVar} options action = do 218 | -- Interruptible mask is enough so long as none of the STM operations below block. 219 | -- 220 | -- Unconditionally set masking state to MaskedInterruptible, even though we might already be at MaskedInterruptible 221 | -- or MaskedUninterruptible, to avoid a branch on parentMaskingState. 222 | interruptiblyMasked do 223 | -- Record the thread as being about to start. Not allowed to retry. 224 | nonblockingAtomically do 225 | status <- nonblockingReadTVar statusVar 226 | assertM (status >= -2) 227 | case status of 228 | Open -> nonblockingWriteTVar' statusVar (status + 1) 229 | Closing -> nonblockingThrowSTM ScopeClosing 230 | Closed -> nonblockingThrowSTM (ErrorCall "ki: scope closed") 231 | 232 | childIds <- spawnChild scope options action 233 | 234 | -- Record the child as having started. Not allowed to retry. 235 | nonblockingAtomically do 236 | starting <- nonblockingReadTVar statusVar 237 | assertM (starting >= 1) 238 | nonblockingWriteTVar' statusVar (starting - 1) 239 | recordChild childrenVar childIds 240 | 241 | pure childIds 242 | 243 | data ChildIds 244 | = ChildIds 245 | {-# UNPACK #-} !Tid 246 | {-# UNPACK #-} !ThreadId 247 | 248 | spawnChild :: Scope -> ThreadOptions -> (Tid -> (forall x. IO x -> IO x) -> UnexceptionalIO ()) -> IO ChildIds 249 | spawnChild scope options action = do 250 | childId <- IntSupply.next nextChildIdSupply 251 | childThreadId <- 252 | forkWithAffinity affinity do 253 | when (not (null label)) do 254 | childThreadId <- myThreadId 255 | labelThread childThreadId label 256 | 257 | for_ allocationLimit \bytes -> do 258 | setAllocationCounter (byteCountToInt64 bytes) 259 | enableAllocationLimit 260 | 261 | let -- Action that sets the masking state from the current (MaskedInterruptible) to the requested one. 262 | atRequestedMaskingState :: IO a -> IO a 263 | atRequestedMaskingState = 264 | case requestedChildMaskingState of 265 | Unmasked -> unsafeUnmask 266 | MaskedInterruptible -> id 267 | MaskedUninterruptible -> uninterruptiblyMasked 268 | 269 | runUnexceptionalIO (action childId atRequestedMaskingState) 270 | 271 | nonblockingAtomically (unrecordChild childrenVar childId) 272 | pure (ChildIds childId childThreadId) 273 | where 274 | Scope {childrenVar, nextChildIdSupply} = scope 275 | ThreadOptions {affinity, allocationLimit, label, maskingState = requestedChildMaskingState} = options 276 | {-# INLINE spawnChild #-} 277 | 278 | -- Record our child by either: 279 | -- 280 | -- * Flipping `Nothing` to `Just childThreadId` (common case: we record child before it unrecords itself) 281 | -- * Flipping `Just _` to `Nothing` (uncommon case: we observe that a child already unrecorded itself) 282 | recordChild :: TVar (IntMap ThreadId) -> ChildIds -> NonblockingSTM () 283 | recordChild childrenVar (ChildIds childId childThreadId) = do 284 | children <- nonblockingReadTVar childrenVar 285 | nonblockingWriteTVar' childrenVar (IntMap.Lazy.alter (maybe (Just childThreadId) (const Nothing)) childId children) 286 | 287 | -- Unrecord a child (ourselves) by either: 288 | -- 289 | -- * Flipping `Just childThreadId` to `Nothing` (common case: parent recorded us first) 290 | -- * Flipping `Nothing` to `Just undefined` (uncommon case: we terminate and unrecord before parent can record us). 291 | unrecordChild :: TVar (IntMap ThreadId) -> Tid -> NonblockingSTM () 292 | unrecordChild childrenVar childId = do 293 | children <- nonblockingReadTVar childrenVar 294 | nonblockingWriteTVar' childrenVar (IntMap.Lazy.alter (maybe (Just undefined) (const Nothing)) childId children) 295 | 296 | -- | Wait until all threads created within a scope terminate. 297 | awaitAll :: Scope -> STM () 298 | awaitAll Scope {childrenVar, statusVar} = do 299 | children <- readTVar childrenVar 300 | guard (IntMap.Lazy.null children) 301 | status <- readTVar statusVar 302 | assertM (status >= -2) 303 | case status of 304 | Open -> guard (status == 0) 305 | Closing -> retry -- block until closed 306 | Closed -> pure () 307 | 308 | -- | Create a child thread to execute an action within a scope. 309 | -- 310 | -- /Note/: The child thread does not mask asynchronous exceptions, regardless of the parent thread's masking state. To 311 | -- create a child thread with a different initial masking state, use 'Ki.forkWith'. 312 | fork :: Scope -> IO a -> IO (Thread a) 313 | fork scope = 314 | forkWith scope defaultThreadOptions 315 | 316 | -- | Variant of 'Ki.fork' for threads that never return. 317 | fork_ :: Scope -> IO Void -> IO () 318 | fork_ scope = 319 | forkWith_ scope defaultThreadOptions 320 | 321 | -- | Variant of 'Ki.fork' that takes an additional options argument. 322 | forkWith :: Scope -> ThreadOptions -> IO a -> IO (Thread a) 323 | forkWith scope opts action = do 324 | resultVar <- newTVarIO NoResultYet 325 | let done result = UnexceptionalIO (atomically (writeTVar resultVar result)) 326 | ChildIds _ childThreadId <- 327 | spawn scope opts \childId masking -> do 328 | unexceptionalTry (masking action) >>= \case 329 | Failure exception -> do 330 | when (not (exceptionIs @ScopeClosing exception)) do 331 | propagateException scope childId exception 332 | -- even put async exceptions that we propagated. this isn't totally ideal because a caller awaiting this 333 | -- thread would not be able to distinguish between async exceptions delivered to this thread, or itself 334 | done (BadResult exception) 335 | Success value -> done (GoodResult value) 336 | let doAwait = 337 | readTVar resultVar >>= \case 338 | NoResultYet -> retry 339 | BadResult exception -> throwSTM exception 340 | GoodResult value -> pure value 341 | pure (makeThread childThreadId doAwait) 342 | 343 | -- | Variant of 'Ki.forkWith' for threads that never return. 344 | forkWith_ :: Scope -> ThreadOptions -> IO Void -> IO () 345 | forkWith_ scope opts action = do 346 | _childThreadId <- 347 | spawn scope opts \childId masking -> 348 | unexceptionalTryEither 349 | ( \exception -> 350 | when (not (exceptionIs @ScopeClosing exception)) do 351 | propagateException scope childId exception 352 | ) 353 | absurd 354 | (masking action) 355 | pure () 356 | 357 | -- | Like 'Ki.fork', but the child thread does not propagate exceptions that are both: 358 | -- 359 | -- * Synchronous (/i.e./ not an instance of 'SomeAsyncException'). 360 | -- * An instance of @e@. 361 | forkTry :: forall e a. (Exception e) => Scope -> IO a -> IO (Thread (Either e a)) 362 | forkTry scope = 363 | forkTryWith scope defaultThreadOptions 364 | 365 | data Result a 366 | = NoResultYet 367 | | BadResult !SomeException -- sync or async 368 | | GoodResult a 369 | 370 | -- | Variant of 'Ki.forkTry' that takes an additional options argument. 371 | forkTryWith :: forall e a. (Exception e) => Scope -> ThreadOptions -> IO a -> IO (Thread (Either e a)) 372 | forkTryWith scope opts action = do 373 | resultVar <- newTVarIO NoResultYet 374 | let done result = UnexceptionalIO (atomically (writeTVar resultVar result)) 375 | ChildIds _ childThreadId <- 376 | spawn scope opts \childId masking -> do 377 | result <- unexceptionalTry (masking action) 378 | case result of 379 | Failure exception -> do 380 | -- then-branch explanation: if the user calls `forkTry @MyAsyncException` for some reason, we want to ignore 381 | -- this request and propagate the async exception. `forkTry` can only be used to catch synchronous exceptions. 382 | let shouldPropagate = 383 | if exceptionIs @e exception 384 | then exceptionIs @SomeAsyncException exception 385 | else not (exceptionIs @ScopeClosing exception) 386 | when shouldPropagate (propagateException scope childId exception) 387 | done (BadResult exception) 388 | Success value -> done (GoodResult value) 389 | let doAwait = 390 | readTVar resultVar >>= \case 391 | NoResultYet -> retry 392 | BadResult exception -> 393 | case fromException @e exception of 394 | Nothing -> throwSTM exception 395 | Just expectedException -> pure (Left expectedException) 396 | GoodResult value -> pure (Right value) 397 | pure (makeThread childThreadId doAwait) 398 | 399 | -- We have a non-`ScopeClosing` exception to propagate to our parent. 400 | -- 401 | -- If our scope has already begun closing (`statusVar` is Closing), then either... 402 | -- 403 | -- (A) We already received a `ScopeClosing`, but then ended up trying to propagate an exception anyway, because we 404 | -- threw a synchronous exception (or were hit by a different asynchronous exception) during our teardown procedure. 405 | -- 406 | -- or 407 | -- 408 | -- (B) We will receive a `ScopeClosing` imminently, because our parent has *just* finished setting `statusVar` to 409 | -- Closing, and will proceed to throw ScopeClosing to all of its children. 410 | -- 411 | -- If (A), our parent has asynchronous exceptions masked, so we must inform it of our exception via `childExceptionVar` 412 | -- rather than throwTo. If (B), either mechanism would work. And because we don't if we're in case (A) or (B), we just 413 | -- `childExceptionVar`. 414 | -- 415 | -- And if our scope has not already begun closing (`statusVar` is not Closing), then we ought to throw our exception to 416 | -- it. But that might fail due to either... 417 | -- 418 | -- (C) Our parent concurrently closing the scope and sending us a `ScopeClosing`; because it has asynchronous 419 | -- exceptions uninterruptibly masked and we only have asynchronous exception *synchronously* masked, its `throwTo` 420 | -- will return `()`, and ours will throw that `ScopeClosing` asynchronous exception. In this case, since we now know 421 | -- our parent is tearing down and has asynchronous exceptions masked, we again inform it via `childExceptionVar`. 422 | -- 423 | -- (D) Some *other* non-`ScopeClosing` asynchronous exception is raised here. This is truly odd: maybe it's a heap 424 | -- overflow exception from the GHC runtime? Maybe some other thread has smuggled our `ThreadId` out and has manually 425 | -- thrown us an exception for some reason? Either way, because we already have an exception that we are trying to 426 | -- propagate, we just scoot these freaky exceptions under the rug. 427 | -- 428 | -- Precondition: interruptibly masked 429 | propagateException :: Scope -> Tid -> SomeException -> UnexceptionalIO () 430 | propagateException Scope {childExceptionVar, parentThreadId, statusVar} childId exception = 431 | UnexceptionalIO (readTVarIO statusVar) >>= \case 432 | Closing -> tryPutChildExceptionVar -- (A) or (B), we don't care which 433 | status -> do 434 | assertM (status >= 0) -- we know status is Open (0+) here; can't be Closed (-2) 435 | loop 436 | where 437 | loop :: UnexceptionalIO () 438 | loop = 439 | unexceptionalTry (propagate exception childId parentThreadId) >>= \case 440 | Failure secondException 441 | | exceptionIs @ScopeClosing secondException -> tryPutChildExceptionVar -- (C) 442 | | otherwise -> loop -- (D) 443 | Success _ -> pure () 444 | 445 | tryPutChildExceptionVar :: UnexceptionalIO () 446 | tryPutChildExceptionVar = 447 | UnexceptionalIO (void (tryPutMVar childExceptionVar exception)) 448 | -------------------------------------------------------------------------------- /ki/src/Ki/Internal/Thread.hs: -------------------------------------------------------------------------------- 1 | module Ki.Internal.Thread 2 | ( Thread, 3 | makeThread, 4 | await, 5 | ) 6 | where 7 | 8 | import Control.Concurrent (ThreadId) 9 | import Control.Exception (BlockedIndefinitelyOnSTM (..)) 10 | import GHC.Conc (STM) 11 | import Ki.Internal.IO (tryEitherSTM) 12 | 13 | -- | A thread. 14 | -- 15 | -- ==== __👉 Details__ 16 | -- 17 | -- * A thread's lifetime is delimited by the scope in which it was created. 18 | -- 19 | -- * The thread that creates a scope is considered the parent of all threads created within it. 20 | -- 21 | -- * If an exception is raised in a child thread, the child either propagates the exception to its parent (see 22 | -- 'Ki.fork'), or returns the exception as a value (see 'Ki.forkTry'). 23 | -- 24 | -- * All threads created within a scope are terminated when the scope closes. 25 | data Thread a = Thread 26 | { threadId :: {-# UNPACK #-} !ThreadId, 27 | await_ :: !(STM a) 28 | } 29 | deriving stock (Functor) 30 | 31 | instance Eq (Thread a) where 32 | Thread ix _ == Thread iy _ = 33 | ix == iy 34 | 35 | instance Ord (Thread a) where 36 | compare (Thread ix _) (Thread iy _) = 37 | compare ix iy 38 | 39 | makeThread :: ThreadId -> STM a -> Thread a 40 | makeThread threadId action = 41 | Thread 42 | { threadId, 43 | -- If *they* are deadlocked, we will *both* will be delivered a wakeup from the RTS. We want to shrug this 44 | -- exception off, because afterwards they'll have put to the result var. But don't shield indefinitely, once will 45 | -- cover this use case and prevent any accidental infinite loops. 46 | await_ = tryEitherSTM (\BlockedIndefinitelyOnSTM -> action) pure action 47 | } 48 | 49 | -- | Wait for a thread to terminate. 50 | await :: Thread a -> STM a 51 | await = 52 | await_ 53 | -------------------------------------------------------------------------------- /ki/src/Ki/Internal/ThreadAffinity.hs: -------------------------------------------------------------------------------- 1 | module Ki.Internal.ThreadAffinity 2 | ( ThreadAffinity (..), 3 | forkWithAffinity, 4 | ) 5 | where 6 | 7 | import Control.Concurrent (ThreadId, forkOS) 8 | import Ki.Internal.IO (forkIO, forkOn) 9 | 10 | -- | What, if anything, a thread is bound to. 11 | data ThreadAffinity 12 | = -- | Unbound. 13 | Unbound 14 | | -- | Bound to a capability. 15 | Capability Int 16 | | -- | Bound to an OS thread. 17 | OsThread 18 | deriving stock (Eq, Show) 19 | 20 | -- forkIO/forkOn/forkOS, switching on affinity 21 | forkWithAffinity :: ThreadAffinity -> IO () -> IO ThreadId 22 | forkWithAffinity = \case 23 | Unbound -> forkIO 24 | Capability n -> forkOn n 25 | OsThread -> forkOS 26 | -------------------------------------------------------------------------------- /ki/src/Ki/Internal/ThreadOptions.hs: -------------------------------------------------------------------------------- 1 | module Ki.Internal.ThreadOptions 2 | ( ThreadOptions (..), 3 | defaultThreadOptions, 4 | ) 5 | where 6 | 7 | import Control.Exception (MaskingState (..)) 8 | import Ki.Internal.ByteCount (ByteCount) 9 | import Ki.Internal.ThreadAffinity (ThreadAffinity (..)) 10 | 11 | -- | 12 | -- 13 | -- [@affinity@]: 14 | -- 15 | -- The affinity of a thread. A thread can be unbound, bound to a specific capability, or bound to a specific OS 16 | -- thread. 17 | -- 18 | -- Default: 'Unbound' 19 | -- 20 | -- [@allocationLimit@]: 21 | -- 22 | -- The maximum number of bytes a thread may allocate before it is delivered an 23 | -- 'Control.Exception.AllocationLimitExceeded' exception. If caught, the thread is allowed to allocate an additional 24 | -- 100kb (tunable with @+RTS -xq@) to perform any necessary cleanup actions; if exceeded, the thread is delivered 25 | -- another. 26 | -- 27 | -- Default: @Nothing@ (no limit) 28 | -- 29 | -- [@label@]: 30 | -- 31 | -- The label of a thread, visible in the [event log](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/runtime_control.html#rts-eventlog) (@+RTS -l@). 32 | -- 33 | -- Default: @""@ (no label) 34 | -- 35 | -- [@maskingState@]: 36 | -- 37 | -- The masking state a thread is created in. To unmask, use 'GHC.IO.unsafeUnmask'. 38 | -- 39 | -- Default: @Unmasked@ 40 | data ThreadOptions = ThreadOptions 41 | { affinity :: ThreadAffinity, 42 | allocationLimit :: Maybe ByteCount, 43 | label :: String, 44 | maskingState :: MaskingState 45 | } 46 | deriving stock (Eq, Show) 47 | 48 | -- | Default thread options. 49 | -- 50 | -- @ 51 | -- 'Ki.ThreadOptions' 52 | -- { 'Ki.affinity' = 'Ki.Unbound' 53 | -- , 'Ki.allocationLimit' = Nothing 54 | -- , 'Ki.label' = "" 55 | -- , 'Ki.maskingState' = 'Unmasked' 56 | -- } 57 | -- @ 58 | defaultThreadOptions :: ThreadOptions 59 | defaultThreadOptions = 60 | ThreadOptions 61 | { affinity = Unbound, 62 | allocationLimit = Nothing, 63 | label = "", 64 | maskingState = Unmasked 65 | } 66 | -------------------------------------------------------------------------------- /ki/test/Tests.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Concurrent (newEmptyMVar, putMVar, readMVar, takeMVar, threadDelay) 4 | import Control.Concurrent.STM (atomically) 5 | import Control.Exception 6 | import Control.Monad 7 | import Data.IORef 8 | import GHC.IO (unsafeUnmask) 9 | import qualified Ki 10 | import Test.Tasty (TestTree, defaultMain, testGroup) 11 | import Test.Tasty.HUnit (testCase) 12 | import Prelude 13 | 14 | main :: IO () 15 | main = 16 | defaultMain (testGroup "Unit tests" tests) 17 | 18 | tests :: [TestTree] 19 | tests = 20 | [ testCase "`fork` throws ErrorCall when the scope is closed" do 21 | scope <- Ki.scoped pure 22 | (atomically . Ki.await =<< Ki.fork scope (pure ())) `shouldThrow` ErrorCall "ki: scope closed" 23 | pure (), 24 | testCase "`fork` throws ScopeClosing to children when the scope is closing" do 25 | Ki.scoped \scope -> do 26 | _ <- 27 | Ki.forkWith scope Ki.defaultThreadOptions {Ki.maskingState = MaskedInterruptible} do 28 | -- Naughty: catch and ignore the ScopeClosing delivered to us 29 | result1 <- try @SomeException (threadDelay maxBound) 30 | show result1 `shouldBe` "Left <>" 31 | -- Try forking a new thread in the closing scope, and assert that (synchronously) throws ScopeClosing 32 | result2 <- try @SomeException (Ki.fork_ scope undefined) 33 | show result2 `shouldBe` "Left <>" 34 | pure (), 35 | testCase "`awaitAll` succeeds when no threads are alive" do 36 | Ki.scoped (atomically . Ki.awaitAll), 37 | testCase "`fork` propagates exceptions" do 38 | (`shouldThrow` A) do 39 | Ki.scoped \scope -> do 40 | Ki.fork_ scope (throwIO A) 41 | atomically (Ki.awaitAll scope), 42 | testCase "`fork` puts exceptions after propagating" do 43 | (`shouldThrow` A) do 44 | Ki.scoped \scope -> do 45 | mask \restore -> do 46 | thread :: Ki.Thread () <- Ki.fork scope (throwIO A) 47 | restore (atomically (Ki.awaitAll scope)) `catch` \(_ :: SomeException) -> pure () 48 | atomically (Ki.await thread), 49 | testCase "`fork` forks in unmasked state regardless of parent's masking state" do 50 | Ki.scoped \scope -> do 51 | _ <- Ki.fork scope (getMaskingState `shouldReturn` Unmasked) 52 | _ <- mask_ (Ki.fork scope (getMaskingState `shouldReturn` Unmasked)) 53 | _ <- uninterruptibleMask_ (Ki.fork scope (getMaskingState `shouldReturn` Unmasked)) 54 | atomically (Ki.awaitAll scope), 55 | testCase "`forkWith` can fork in interruptibly masked state regardless of paren't masking state" do 56 | Ki.scoped \scope -> do 57 | _ <- 58 | Ki.forkWith 59 | scope 60 | Ki.defaultThreadOptions {Ki.maskingState = MaskedInterruptible} 61 | (getMaskingState `shouldReturn` MaskedInterruptible) 62 | _ <- 63 | mask_ do 64 | Ki.forkWith 65 | scope 66 | Ki.defaultThreadOptions {Ki.maskingState = MaskedInterruptible} 67 | (getMaskingState `shouldReturn` MaskedInterruptible) 68 | _ <- 69 | uninterruptibleMask_ do 70 | Ki.forkWith 71 | scope 72 | Ki.defaultThreadOptions {Ki.maskingState = MaskedInterruptible} 73 | (getMaskingState `shouldReturn` MaskedInterruptible) 74 | atomically (Ki.awaitAll scope), 75 | testCase "`forkWith` can fork in uninterruptibly masked state regardless of paren't masking state" do 76 | Ki.scoped \scope -> do 77 | _ <- 78 | Ki.forkWith 79 | scope 80 | Ki.defaultThreadOptions {Ki.maskingState = MaskedUninterruptible} 81 | (getMaskingState `shouldReturn` MaskedUninterruptible) 82 | _ <- 83 | mask_ do 84 | Ki.forkWith 85 | scope 86 | Ki.defaultThreadOptions {Ki.maskingState = MaskedUninterruptible} 87 | (getMaskingState `shouldReturn` MaskedUninterruptible) 88 | _ <- 89 | uninterruptibleMask_ do 90 | Ki.forkWith 91 | scope 92 | Ki.defaultThreadOptions {Ki.maskingState = MaskedUninterruptible} 93 | (getMaskingState `shouldReturn` MaskedUninterruptible) 94 | atomically (Ki.awaitAll scope), 95 | testCase "`forkTry` can catch sync exceptions" do 96 | Ki.scoped \scope -> do 97 | result :: Ki.Thread (Either A ()) <- Ki.forkTry scope (throw A) 98 | atomically (Ki.await result) `shouldReturn` Left A, 99 | testCase "`forkTry` can propagate sync exceptions" do 100 | (`shouldThrow` A) do 101 | Ki.scoped \scope -> do 102 | thread :: Ki.Thread (Either A2 ()) <- Ki.forkTry scope (throw A) 103 | atomically (Ki.await thread), 104 | testCase "`forkTry` propagates async exceptions" do 105 | (`shouldThrow` B) do 106 | Ki.scoped \scope -> do 107 | thread :: Ki.Thread (Either B ()) <- Ki.forkTry scope (throw B) 108 | atomically (Ki.await thread), 109 | testCase "`forkTry` puts exceptions after propagating" do 110 | (`shouldThrow` A2) do 111 | Ki.scoped \scope -> do 112 | mask \restore -> do 113 | thread :: Ki.Thread (Either A ()) <- Ki.forkTry scope (throwIO A2) 114 | restore (atomically (Ki.awaitAll scope)) `catch` \(_ :: SomeException) -> pure () 115 | atomically (Ki.await thread), 116 | testCase "child propagates exceptions thrown during cleanup" do 117 | (`shouldThrow` A) do 118 | Ki.scoped \scope -> do 119 | ready <- newEmptyMVar 120 | Ki.forkWith_ scope Ki.defaultThreadOptions {Ki.maskingState = MaskedInterruptible} do 121 | putMVar ready () 122 | unsafeUnmask (forever (threadDelay maxBound)) `finally` throwIO A 123 | takeMVar ready, 124 | testCase "regression test https://github.com/awkward-squad/ki/issues/33" do 125 | ref <- newIORef False 126 | ready <- newEmptyMVar 127 | 128 | handle (\A -> pure ()) do 129 | Ki.scoped \scope1 -> do 130 | _ <- 131 | Ki.fork scope1 do 132 | readMVar ready 133 | throwIO A 134 | Ki.scoped \scope2 -> do 135 | _ <- 136 | Ki.fork scope2 do 137 | (putMVar ready () >> threadDelay 1_000_000) `catch` \(_ :: SomeException) -> 138 | writeIORef ref True 139 | atomically (Ki.awaitAll scope2) 140 | 141 | readIORef ref `shouldReturn` True 142 | ] 143 | 144 | data A = A 145 | deriving stock (Eq, Show) 146 | deriving anyclass (Exception) 147 | 148 | data A2 = A2 149 | deriving stock (Eq, Show) 150 | deriving anyclass (Exception) 151 | 152 | data B = B 153 | deriving stock (Eq, Show) 154 | 155 | instance Exception B where 156 | toException = asyncExceptionToException 157 | fromException = asyncExceptionFromException 158 | 159 | shouldBe :: (Eq a, Show a) => a -> a -> IO () 160 | shouldBe actual expected = do 161 | unless (actual == expected) (fail ("expected " ++ show expected ++ ", got " ++ show actual)) 162 | 163 | shouldReturn :: (Eq a, Show a) => IO a -> a -> IO () 164 | shouldReturn action expected = do 165 | actual <- action 166 | actual `shouldBe` expected 167 | 168 | shouldThrow :: (Show a, Eq e, Exception e) => IO a -> e -> IO () 169 | shouldThrow action expected = 170 | try @SomeException action >>= \case 171 | Left exception | fromException exception == Just expected -> pure () 172 | Left exception -> 173 | fail ("expected exception " ++ displayException expected ++ ", got exception " ++ displayException exception) 174 | Right value -> fail ("expected exception " ++ displayException expected ++ ", got " ++ show value) 175 | --------------------------------------------------------------------------------