backoff-0.1.1/0000755000175000017500000000000014702751135011603 5ustar kylekylebackoff-0.1.1/update-gh-pages-for-tag0000755000175000017500000000257014675560123016051 0ustar kylekyle#!/bin/bash set -xeuo pipefail TMP=tmp NAME=backoff MAIN=doc GIT="git@github.com:ocaml-multicore/$NAME.git" DOC="_build/default/_doc/_html" GH_PAGES=gh-pages TAG="$1" if ! [ -e $NAME.opam ] || [ $# -ne 1 ] || \ { [ "$TAG" != main ] && ! [ "$(git tag -l "$TAG")" ]; }; then CMD="${0##*/}" cat << EOF Usage: $CMD tag-name-or-main This script - clones the repository into a temporary directory ($TMP/$NAME), - builds the documentation for the specified tag or main, - updates $GH_PAGES branch with the documentation in directory for the tag, - prompts whether to also update the main documentation in $MAIN directory, and - prompts whether to push changes to $GH_PAGES. EOF exit 1 fi mkdir $TMP cd $TMP git clone $GIT cd $NAME git checkout "$TAG" dune build @doc --root=. git checkout $GH_PAGES if [ "$TAG" != main ]; then echo "Updating the $TAG doc." if [ -e "$TAG" ]; then git rm -rf "$TAG" fi cp -r $DOC "$TAG" git add "$TAG" fi read -p "Update the main doc? (y/N) " -n 1 -r echo if [[ $REPLY =~ ^[Yy]$ ]]; then if [ -e $MAIN ]; then git rm -rf $MAIN fi cp -r $DOC $MAIN git add $MAIN else echo "Skipped main doc update." fi git commit -m "Update $NAME doc for $TAG" read -p "Push changes to $GH_PAGES? (y/N) " -n 1 -r echo if ! [[ $REPLY =~ ^[Yy]$ ]]; then echo "Leaving $TMP for you to examine." exit 1 fi git push cd .. cd .. rm -rf $TMP backoff-0.1.1/src/0000755000175000017500000000000014675560123012376 5ustar kylekylebackoff-0.1.1/src/backoff.ml0000644000175000017500000000541114675560123014324 0ustar kylekyle(* * Copyright (c) 2015, Théo Laurent * Copyright (c) 2015, KC Sivaramakrishnan * Copyright (c) 2021, Sudha Parimala * Copyright (c) 2023, Vesa Karvonen * * Permission to use, copy, modify, and/or distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) type t = int let single_mask = Bool.to_int (Domain.recommended_domain_count () = 1) - 1 let bits = 5 let max_wait_log = 30 (* [Random.bits] returns 30 random bits. *) let mask = (1 lsl bits) - 1 let create ?(lower_wait_log = 4) ?(upper_wait_log = 17) () = assert ( 0 <= lower_wait_log && lower_wait_log <= upper_wait_log && upper_wait_log <= max_wait_log); (upper_wait_log lsl (bits * 2)) lor (lower_wait_log lsl bits) lor lower_wait_log let get_upper_wait_log backoff = backoff lsr (bits * 2) let get_lower_wait_log backoff = (backoff lsr bits) land mask let get_wait_log backoff = backoff land mask let reset backoff = let lower_wait_log = get_lower_wait_log backoff in backoff land lnot mask lor lower_wait_log (* We don't want [once] to be inlined. This may avoid code bloat. *) let[@inline never] once backoff = (* We call [Random.bits] first. In this case this helps to reduce register pressure so that fewer words will be allocated from the stack. *) let t = Random.bits () in let wait_log = get_wait_log backoff in let wait_mask = (1 lsl wait_log) - 1 in (* We use a ref and a countdown while-loop (uses one variable) instead of a for-loop (uses two variables) to reduce register pressure. Local ref does not allocate with native compiler. *) let t = ref (t land wait_mask land single_mask) in while 0 <= !t do Domain.cpu_relax (); t := !t - 1 done; let upper_wait_log = get_upper_wait_log backoff in (* We recompute [wait_log] to reduce register pressure. *) let wait_log = get_wait_log backoff in (* [Bool.to_int] generates branchless code, this reduces branch predictor pressure and generates shorter code. *) let next_wait_log = wait_log + Bool.to_int (wait_log < upper_wait_log) in backoff - wait_log + next_wait_log let default = create () backoff-0.1.1/src/domain.ocaml4.ml0000644000175000017500000000010114675560123015345 0ustar kylekylelet cpu_relax = Thread.yield let recommended_domain_count () = 1 backoff-0.1.1/src/backoff.mli0000644000175000017500000000363614675560123014504 0ustar kylekyle(* * Copyright (c) 2015, Théo Laurent * Copyright (c) 2015, KC Sivaramakrishnan * Copyright (c) 2023, Vesa Karvonen * * Permission to use, copy, modify, and/or distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) (** Randomized exponential backoff mechanism. *) type t [@@immediate] (** Type of backoff values. *) val max_wait_log : int (** Logarithm of the maximum allowed value for wait. *) val create : ?lower_wait_log:int -> ?upper_wait_log:int -> unit -> t (** [create] creates a backoff value. [upper_wait_log], [lower_wait_log] override the logarithmic upper and lower bound on the number of spins executed by {!once}. *) val default : t (** [default] is equivalent to [create ()]. *) val once : t -> t (** [once b] executes one random wait and returns a new backoff with logarithm of the current maximum value incremented unless it is already at [upper_wait_log] of [b]. Note that this uses the default Stdlib [Random] per-domain generator. *) val reset : t -> t (** [reset b] returns a backoff equivalent to [b] except with current value set to the [lower_wait_log] of [b]. *) val get_wait_log : t -> int (** [get_wait_log b] returns logarithm of the maximum value of wait for next {!once}. *) backoff-0.1.1/src/dune0000644000175000017500000000061414675560123013255 0ustar kylekyle(* -*- tuareg -*- *) let maybe_threads = if Jbuild_plugin.V1.ocaml_version < "5" then "threads" else "" let () = Jbuild_plugin.V1.send @@ {| (library (name backoff) (public_name backoff) (libraries |} ^ maybe_threads ^ {| )) (rule (targets domain.ml) (deps domain.ocaml4.ml) (enabled_if (< %{ocaml_version} 5.0.0)) (action (progn (copy domain.ocaml4.ml domain.ml)))) |} backoff-0.1.1/README.md0000644000175000017500000000721714675560123013075 0ustar kylekyle[API reference](https://ocaml-multicore.github.io/backoff/doc/backoff/Backoff/index.html) # backoff - exponential backoff mechanism **backoff** provides an [exponential backoff mechanism](https://en.wikipedia.org/wiki/Exponential_backoff) [1]. It reduces contention by making a domain back off after failing an operation contested by another domain, like acquiring a lock or performing a `CAS` operation. ## About contention Contention is what happens when multiple CPU cores try to access the same location(s) in parallel. Let's take the example of multiple CPU cores trying to perform a `CAS` on the same location at the same time. Only one is going to success at each round of retries. By writing on a shared location, it invalidates all other CPUs' caches. So at each round each CPU will have to read the memory location again, leading to quadratic O(n²) bus traffic. ## Exponential backoff Failing to access a shared resource means there is contention: some other CPU cores are trying to access it at the same time. To avoid quadratic bus traffic, the idea exploited by exponential backoff is to make each CPU core wait (spin) a random bit before retrying. This way, they will try to access the resource at a different time: that not only strongly decreases bus traffic but that also gets them a better chance to get the resource, at they probably will compete for it against less other CPU cores. Failing again probably means contention is high, and they need to wait longer. In fact, each consecutive fail of a single CPU core will make it wait twice longer (_exponential_ backoff !). Obviously, they cannot wait forever: there is an upper limit on the number of times the initial waiting time can be doubled (see [Tuning](#tuning)), but intuitively, a good waiting time should be at least around the time the contested operation takes (in our example, the operation is a CAS) and at most a few times that amount. ## Tuning For better performance, backoff can be tuned. `Backoff.create` function has two optional arguments for that: `upper_wait_log` and `lower_wait_log` that defines the logarithmic upper and lower bound on the number of spins executed by {!once}. ## Drawbacks This mechanism has some drawbacks. First, it adds some delays: for example, when a domain releases a contended lock, another domain, that has backed off after failing acquiring it, will still have to finish its back-off loop before retrying. Second, this increases any unfairness: any other thread that arrives at that time or that has failed acquiring the lock for a lesser number of times is more likely to acquire it as it will probably have a shorter waiting time. ## Example To illustrate how to use backoff, here is a small implementation of `test and test-and-set` spin lock [2]. ```ocaml type t = bool Atomic.t let create () = Atomic.make false let rec acquire ?(backoff = Backoff.detault) t = if Atomic.get t then begin Domain.cpu_relax (); acquire ~backoff t end else if not (Atomic.compare_and_set t false true) then acquire ~backoff:(Backoff.once backoff) t let release t = Atomic.set t false ``` This implementation can also be found [here](bench/taslock.ml), as well as a small [benchmark](bench/test_tas.ml) to compare it to the same TAS lock but without backoff. It can be launched with: ```sh dune exec ./bench/test_tas.exe > bench.data ``` and displayed (on linux) with: ```sh gnuplot -p -e 'plot for [col=2:4] "bench.data" using 1:col with lines title columnheader' ``` ## References [1] Adaptive backoff synchronization techniques, A. Agarwal, M. Cherian (1989) [2] Dynamic Decentralized Cache Schemes for MIMD Parallel Processors, L.Rudolf, Z.Segall (1984) backoff-0.1.1/dune-project0000644000175000017500000000074214675560123014134 0ustar kylekyle(lang dune 3.3) (name backoff) (version 0.1.1) (generate_opam_files true) (source (github ocaml-multicore/backoff)) (authors "KC Sivaramakrishnan ") (maintainers "Carine Morel ") (homepage "https://github.com/ocaml-multicore/backoff") (license ISC) (package (name backoff) (synopsis "Exponential backoff mechanism for OCaml") (depends (ocaml (>= 4.12)) (alcotest (and (>= 1.7.0) :with-test)) (domain_shims (and (>= 0.1.0) :with-test)))) backoff-0.1.1/.ocamlformat0000644000175000017500000000004314675560123014111 0ustar kylekyleprofile = default version = 0.26.2 backoff-0.1.1/bench/0000755000175000017500000000000014675560123012666 5ustar kylekylebackoff-0.1.1/bench/orchestrator.ml0000644000175000017500000000216714675560123015745 0ustar kylekyletype t = { ready : int Atomic.t; total_domains : int; round : int Atomic.t; rounds : int; } let init ~total_domains ~rounds = { ready = Atomic.make 0; total_domains; round = Atomic.make 0; rounds } let wait_until_all_ready ?(round = 0) { ready; total_domains; _ } = while Atomic.get ready < total_domains * (round + 1) do () done let worker ({ ready; round; rounds; _ } as t) f = Atomic.incr ready; wait_until_all_ready t; (* all domains are up at this point *) for i = 1 to rounds do (* wait for signal to start work *) while Atomic.get round < i do () done; f (); (* signal that we're done *) Atomic.incr ready done let run ?(drop_first = true) ({ round; rounds; _ } as t) = wait_until_all_ready t; (* all domains are up, can start benchmarks *) let results = ref [] in for i = 1 to rounds do let start_time = Unix.gettimeofday () in Atomic.incr round; wait_until_all_ready ~round:i t; let end_time = Unix.gettimeofday () in let diff = end_time -. start_time in if drop_first && i == 1 then () else results := diff :: !results done; !results backoff-0.1.1/bench/taslock.ml0000644000175000017500000000235114675560123014661 0ustar kylekyle(* TASlock, TTASlock implementations from The Art of Multiprocessor Programming - M.Herlihy, N. Shavit, V. Luchangco, M. Spear *) module type LOCK = sig type t val create : unit -> t val acquire : t -> unit val release : t -> unit end module TASlock : LOCK = struct type t = bool Atomic.t let create () = Atomic.make false let rec acquire t = if not @@ Atomic.compare_and_set t false true then ( Domain.cpu_relax (); acquire t) let release t = Atomic.set t false end module TTASlock : LOCK = struct type t = bool Atomic.t let create () = Atomic.make false let rec acquire t = if Atomic.get t then ( Domain.cpu_relax (); acquire t) else if not (Atomic.compare_and_set t false true) then ( Domain.cpu_relax (); acquire t) let release t = Atomic.set t false end module TTASlock_boff : LOCK = struct type t = bool Atomic.t let create () = Atomic.make false let rec acquire_ ?(backoff = Backoff.default) t = if Atomic.get t then ( Domain.cpu_relax (); acquire_ ~backoff t) else if not (Atomic.compare_and_set t false true) then acquire_ ~backoff:(Backoff.once backoff) t let acquire t = acquire_ t let release t = Atomic.set t false end backoff-0.1.1/bench/dune0000644000175000017500000000010714675560123013542 0ustar kylekyle(executables (names test_tas) (libraries domain_shims backoff unix)) backoff-0.1.1/bench/orchestrator.mli0000644000175000017500000000265014675560123016113 0ustar kylekyle(** Helper library that ensures all workers have started before any starts making progress on the benchmark. *) type t (** An orchestrator is similar to a counter that ensures each domain has started and complete each round simultanously. All domains wait for the other before beginning the next round. *) val init : total_domains:int -> rounds:int -> t (** [init ~total_domains:nd ~rounds:nr] create an orchestrator that will run [nr] rounds for a test that uses exactly [nd] worker domains *) val worker : t -> (unit -> unit) -> unit (** [worker t f] builds the function to pass to [Domain.spawn] while using the orchestrator [t]. Doing [Domain.spawn (fun () -> worker t f)] is similar to [Domain.spawn f] except that the orchestrator is used to synchronize all domains progress. *) val run : ?drop_first:bool -> t -> float List.t (** [run t] is launching the benchmark by enabling domains to progress. Benchmarks code should have the following structure : {[ (* Initialize the orchestrator, with [nd] the number of domains we want. *) let orchestrator = init ~total_domain:nd ~round:100 in (* Spawn domains with [worker] *) let domains = List.init nd (fun _ -> Domain.spawn (fun () -> worker orchestrator (fun () -> some_function ()))) in (* Run the benchmarks by freeing domains round by round. *) let times = run orchestrator in ... ]} *) backoff-0.1.1/bench/test_tas.ml0000644000175000017500000000534514675560123015055 0ustar kylekyleopen Taslock let mean ?(cut_minmax = 0) data = let data = List.sort compare data in let length = List.length data in if cut_minmax * 2 > length then failwith "Not enougth data"; let data = List.filteri (fun i _ -> i >= cut_minmax && i <= length - cut_minmax) data in let sum = List.fold_left (fun curr_sum b -> curr_sum +. b) 0. data in let n = Int.to_float (List.length data) in sum /. n let print ~gnuplot res = if gnuplot then let n_domains = List.hd res |> snd |> List.map fst in let nlines = List.length n_domains in let names, lines = List.fold_left (fun (names, acc) (name, res) -> ( names ^ name ^ "\t", List.map2 (fun tmp (_, mean) -> tmp ^ "\t" ^ Float.to_string mean) acc res )) ("ndomains\t", List.init nlines (fun _ -> "")) res in let lines = names :: List.map2 (fun line nd -> Int.to_string nd ^ line) lines n_domains in List.iter (Format.printf "%s@.") lines else List.iter (fun (name, means) -> Format.printf "%s : @." name; List.iter (fun (ndomain, mean) -> Format.printf " for ndomain= %d : %f.6@." ndomain mean) means) res (* This test is here to compare a TAS lock performances with or without backoff*) let test_taslock ?(gnuplot = false) () = let test (module Lock : LOCK) ndomain nlock rounds = let orch = Orchestrator.init ~total_domains:ndomain ~rounds in let counter = ref 0 in let lock = Lock.create () in let incr () = Lock.acquire lock; incr counter; Lock.release lock in let domains = List.init ndomain (fun _ -> Domain.spawn (fun () -> Orchestrator.worker orch (fun () -> for _ = 0 to nlock - 1 do incr () done))) in let res = Orchestrator.run orch in List.iter Domain.join domains; res in let nlock, nround = (10_000, 100) in let all_lock = [ ("TAS-lock", (module TASlock : LOCK)); ("TTAS-lock", (module TTASlock)); ("TTAS-lock-with-backoff", (module TTASlock_boff)); ] in let res = List.map (fun (name, (module Lock : LOCK)) -> ( name, (List.map (fun ndomain -> let data = test (module Lock) ndomain nlock nround in Gc.major (); let mean = mean ~cut_minmax:(nround / 20) data in (ndomain, mean))) [ 1; 2; 3; 4; 5; 6; 7 ] )) all_lock in print ~gnuplot res let _ = test_taslock ~gnuplot:true () (* dune exec ./bench/test_taslock.exe > bench.data gnuplot -p -e 'plot for [col=2:4] "bench.data" using 1:col with lines title columnheader' *) backoff-0.1.1/LICENSE.md0000644000175000017500000000163514675560123013220 0ustar kylekyleCopyright (c) 2015, Théo Laurent Copyright (c) 2016, KC Sivaramakrishnan Copyright (c) 2021, Sudha Parimala Copyright (c) 2023, Vesa Karvonen Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. backoff-0.1.1/.prettierrc0000644000175000017500000000021514675560123013771 0ustar kylekyle{ "arrowParens": "avoid", "bracketSpacing": false, "printWidth": 80, "semi": false, "singleQuote": true, "proseWrap": "always" } backoff-0.1.1/backoff.opam0000644000175000017500000000140014675560123014053 0ustar kylekyleversion: "0.1.1" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Exponential backoff mechanism for OCaml" maintainer: ["Carine Morel "] authors: ["KC Sivaramakrishnan "] license: "ISC" homepage: "https://github.com/ocaml-multicore/backoff" bug-reports: "https://github.com/ocaml-multicore/backoff/issues" depends: [ "dune" {>= "3.3"} "ocaml" {>= "4.12"} "alcotest" {>= "1.7.0" & with-test} "domain_shims" {>= "0.1.0" & with-test} "odoc" {with-doc} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/ocaml-multicore/backoff.git"backoff-0.1.1/.gitignore0000644000175000017500000000032314675560123013575 0ustar kylekyle# ocamlbuild working directory _build/ # ocamlbuild targets *.byte *.native # Merlin configuring file for Vim and Emacs .merlin # Dune generated files *.install # Local OPAM switch _opam/ tmp *~ \.\#* \#*# backoff-0.1.1/test/0000755000175000017500000000000014675560123012566 5ustar kylekylebackoff-0.1.1/test/backoff_test.ml0000644000175000017500000000124514675560123015554 0ustar kylekylelet test_basics () = let b = Backoff.create ~lower_wait_log:5 ~upper_wait_log:6 () in Alcotest.(check' int) ~msg:"initial is lower" ~expected:5 ~actual:(Backoff.get_wait_log b); let b = Backoff.once b in Alcotest.(check' int) ~msg:"incremented once" ~expected:6 ~actual:(Backoff.get_wait_log b); let b = Backoff.once b in Alcotest.(check' int) ~msg:"not incremented above upper" ~expected:6 ~actual:(Backoff.get_wait_log b); let b = Backoff.reset b in Alcotest.(check' int) ~msg:"reset to lower" ~expected:5 ~actual:(Backoff.get_wait_log b) let () = Alcotest.run "Backoff" [ ("basics", [ Alcotest.test_case "" `Quick test_basics ]) ] backoff-0.1.1/test/dune0000644000175000017500000000007414675560123013445 0ustar kylekyle(tests (names backoff_test) (libraries alcotest backoff)) backoff-0.1.1/HACKING.md0000644000175000017500000000064714675560123013204 0ustar kylekyle### Formatting This project uses [ocamlformat](https://github.com/ocaml-ppx/ocamlformat) (for OCaml) and [prettier](https://prettier.io/) (for Markdown). ### To make a new release 1. Update [CHANGES.md](CHANGES.md). 2. Run `dune-release tag VERSION` to create a tag for the new `VERSION`. 3. Run `dune-release` to publish the new `VERSION`. 4. Run `./update-gh-pages-for-tag VERSION` to update the online documentation. backoff-0.1.1/CHANGES.md0000644000175000017500000000021314675560123013175 0ustar kylekyle## 0.1.1 - Ported to 4.12 and optimized for size (@polytypic) ## 0.1.0 - Initial version based on backoff from kcas (@lyrm, @polytypic) backoff-0.1.1/.github/0000755000175000017500000000000014675560123013147 5ustar kylekylebackoff-0.1.1/.github/workflows/0000755000175000017500000000000014675560123015204 5ustar kylekylebackoff-0.1.1/.github/workflows/workflow.yml0000644000175000017500000000174214675560123017605 0ustar kylekylename: ci on: pull_request: push: branches: - main jobs: test-on-windows: strategy: fail-fast: false matrix: ocaml-compiler: - ocaml.5.0.0,ocaml-option-mingw - ocaml.5.1.1,ocaml-option-mingw - ocaml.5.2.0,ocaml-option-mingw runs-on: windows-latest steps: - name: Check out code uses: actions/checkout@v3 - name: Set up OCaml uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} opam-repositories: | dra27: https://github.com/dra27/opam-repository.git#windows-5.0 default: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset standard: https://github.com/ocaml/opam-repository.git - name: Install dependencies run: opam install . --deps-only --with-test - name: Build run: opam exec -- dune build - name: Test run: opam exec -- dune runtest