diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml new file mode 100644 index 0000000..f55e6b3 --- /dev/null +++ b/.github/workflows/build.yml @@ -0,0 +1,38 @@ +name: build +on: [push] +defaults: + run: + working-directory: repo +jobs: + test: + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + racket-version: [ '7.4', '7.9', '8.0', '8.6', stable ] + steps: + - uses: actions/checkout@v2 + with: { path: repo } + - uses: Bogdanp/setup-racket@v1.5 + with: + version: ${{ matrix.racket-version }} + dest: '$GITHUB_WORKSPACE/racket' + sudo: never + - name: install + run: raco pkg install --installation --auto --link mvar-{doc,lib,test} + - name: test + run: raco test -ep mvar-{doc,lib,test} + + - name: deploy_docs + if: ${{ github.event_name != 'pull_request' && github.ref == 'refs/heads/master' && matrix.racket-version == 'stable' }} + run: | + set -e + scribble +m --redirect https://docs.racket-lang.org/local-redirect/index.html \ + --dest docs --dest-name index mvar-doc/scribblings/data/mvar.scrbl + cd docs + git init -b gh-pages + git config user.name 'GitHub Actions' + git config user.email 'lexi.lambda@gmail.com' + git add . + git commit -m 'Deploy to GitHub Pages' + git push --force 'https://lexi-lambda:${{ github.token }}@github.com/${{ github.repository }}' gh-pages diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..46156c2 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +/build/ +compiled/ +doc/ +*~ diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..16a9cc8 --- /dev/null +++ b/LICENSE @@ -0,0 +1,17 @@ +ISC License + +Copyright (c) 2023, Alexis King + +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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..22343c5 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# mvar [![Build Status](https://img.shields.io/github/actions/workflow/status/lexi-lambda/racket-mvar/build.yml?branch=master)](https://github.com/lexi-lambda/racket-mvar/actions/workflows/build.yml) [![Scribble Docs](https://img.shields.io/badge/docs-built-blue)][mvar-doc] + +This library provides a Racket implementation of Haskell’s `MVar`s. To use it, install the `mvar` package: + +``` +$ raco pkg install mvar +``` + +[For more information, see the documentation.][mvar-doc] + +[mvar-doc]: https://lexi-lambda.github.io/racket-mvar/ diff --git a/mvar-doc/info.rkt b/mvar-doc/info.rkt new file mode 100644 index 0000000..b0e0f80 --- /dev/null +++ b/mvar-doc/info.rkt @@ -0,0 +1,12 @@ +#lang info + +(define version "1.0") + +(define collection 'multi) + +(define deps + '("base")) +(define build-deps + '(["mvar-lib" #:version "1.0"] + "racket-doc" + ["scribble-lib" #:version "1.49"])) diff --git a/mvar-doc/scribblings/data/info.rkt b/mvar-doc/scribblings/data/info.rkt new file mode 100644 index 0000000..4baf3dd --- /dev/null +++ b/mvar-doc/scribblings/data/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define scribblings '(["mvar.scrbl" ()])) diff --git a/mvar-doc/scribblings/data/mvar.scrbl b/mvar-doc/scribblings/data/mvar.scrbl new file mode 100644 index 0000000..d0f864e --- /dev/null +++ b/mvar-doc/scribblings/data/mvar.scrbl @@ -0,0 +1,192 @@ +#lang scribble/manual + +@(begin + (require (for-label data/mvar + racket/base + racket/contract) + scribble/example + scriblib/autobib) + + (define (reftech . pre-content) + (apply tech pre-content #:doc '(lib "scribblings/reference/reference.scrbl"))) + + (define-cite ~cite citet generate-bibliography) + (define concurrent-haskell + (make-bib + #:title "Concurrent Haskell" + #:author (authors (author-name "Simon" "Peyton Jones") "Andrew Gordon" "Sigbjorn Finne") + #:location "Principles of Programming Languages (POPL)" + #:date 1996 + #:doi "10.1145/237721.237794")) + + (define make-mvar-eval (make-eval-factory '(data/mvar racket/contract))) + (define-syntax-rule (mvar-examples body ...) + (examples #:eval (make-mvar-eval) #:once body ...))) + +@title{M-vars: Synchronized Boxes} +@author{@author+email["Alexis King" "lexi.lambda@gmail.com"]} +@margin-note{The source of this manual is available on @hyperlink["https://github.com/lexi-lambda/racket-mvar/blob/master/mvar-doc/scribblings/mvar.scrbl"]{GitHub.}} + +@defmodule[data/mvar]{ + +@margin-note{M-vars originate in Haskell, where they are known as @code{MVar}s. This library is based on the @hyperlink["https://hackage.haskell.org/package/base-4.19.0.0/docs/Control-Concurrent-MVar.html"]{modern API provided by GHC}, which differs in some details from their original presentation in @citet[concurrent-haskell]. Most notably, @racket[mvar-put!] on a full M-var blocks (instead of raising an exception), and @racket[mvar-peek] is atomic.} + +An @deftech{M-var} is a mutable data structure useful in concurrent programs. Like a @reftech{box}, an M-var is a mutable reference cell that can hold a single value. Unlike a box, an M-var can also be @deftech{empty}, holding no value at all. When a value is placed into an empty M-var using @racket[mvar-put!], the M-var becomes @deftech{full}, and it remains full until the value is removed using @racket[mvar-take!]. If a thread attempts to put a value into an M-var that is already full, the thread waits until the M-var is emptied. Dually, if a thread attempts to take a value from an M-var that is currently empty, it waits until the M-var is filled. + +It is also possible to atomically read the contents of a full M-var without removing its value using @racket[mvar-peek]. Like @racket[mvar-take!], using @racket[mvar-peek] on an empty M-var waits until it is filled. Each operation also comes in a polling variant: @racket[mvar-try-put!], @racket[mvar-try-take!], and @racket[mvar-try-peek] always return immediately and simply fail instead of blocking. For maximum flexibility, M-vars can also be combined with other @reftech{synchronizable events} using @racket[mvar-put!-evt], @racket[mvar-take!-evt], and @racket[mvar-peek-evt]. + +The blocking behavior of M-var operations makes it a remarkably flexible building block in concurrent programs, as it is effectively a combination of a @reftech{box}, a @reftech{semaphore}, and a @reftech{channel}. Even just a single M-var can be used in many different ways: +@; +@itemlist[ + @item{If separate processes are tasked with filling and emptying an M-var, it behaves like an @reftech{asynchronous channel} with a buffer size of 1. Producers use @racket[mvar-put!] to send a value, and consumers use @racket[mvar-take!] to receive a value.} + + @item{If an M-var is normally kept full, it behaves like a @reftech{box} protected by a @reftech{semaphore}. Readers use @racket[mvar-peek] and do not block each other. Writers use @racket[mvar-take!] to acquire the lock and @racket[mvar-put!] to both update the value and release the lock.} + + @item{If an M-var is normally kept empty, it behaves like a @hyperlink["https://en.wikipedia.org/wiki/Monitor_(synchronization)#Nonblocking_condition_variables"]{nonblocking, broadcast condition variable}. @racket[mvar-peek] is used to wait on the condition, and @racket[mvar-put!] followed immediately by @racket[mvar-take!] is used to notify waiters.} + + @item{If an M-var starts empty, is filled exactly once, and subsequently remains full, @racket[mvar-peek-evt] can be used to obtain a @reftech{synchronizable event} that remains permanently @reftech{ready for synchronization} once it has been signaled.}] +@; +This list is far from exhaustive, and multiple M-vars used in concert can be even more flexible.} + +@section[#:tag "ordering-and-fairness"]{Ordering and Fairness} + +@tech{M-var} synchronization is @deftech{fair}: if a thread is blocked on an M-var operation, and opportunities for the operation to complete occur infinitely often, the operation is guaranteed to eventually complete. + +Additionally, if a thread is blocked on a call to @racket[mvar-peek], the call is guaranteed to complete the next time the M-var is @tech[#:key "full"]{filled}, even if another thread is blocked on a call to @racket[mvar-take!] on the same M-var. In other words, whenever @racket[mvar-peek] and @racket[mvar-take!] compete to read the next value of an @tech{empty} M-var, @racket[mvar-peek] always “wins”. Since @racket[mvar-peek] is not exclusive—that is, it does not preclude another thread from reading the same M-var after it completes—this preference for @racket[mvar-peek] ensures that the maximum number of threads are woken up each time an M-var is filled. + +@section[#:tag "core-operations"]{Core Operations} + +@defproc*[([(make-mvar) mvar?] + [(make-mvar [v any/c]) mvar?])]{ +Creates and returns a new @tech{M-var}. If called with no arguments, the returned M-var is initially @tech{empty}. If called with one argument, the returned M-var is initially @tech{full} and contains @racket[v]. + +@(mvar-examples + (make-mvar) + (make-mvar 42))} + +@defproc[(mvar? [v any/c]) boolean?]{ +Returns @racket[#t] if @racket[v] is an @tech{M-var}, otherwise returns @racket[#f].} + +@defproc[(mvar-put! [mv mvar?] [v any/c] [#:enable-break? enable-break? any/c #f]) void?]{ +Fills @racket[mv] with the value @racket[v]. If @racket[mv] is already @tech{full}, @racket[mvar-put!] blocks until it is @tech[#:key "empty"]{emptied}. + +If @racket[enable-break?] is not @racket[#f], @reftech{breaks} are explicitly enabled while waiting on @racket[mv]. If breaks are disabled when @racket[mvar-put!] is called, then either @racket[mv] is filled or an @racket[exn:break] exception is raised, but not both. + +@(mvar-examples + (define mv (make-mvar)) + mv + (mvar-put! mv 42) + mv)} + +@defproc[(mvar-try-put! [mv mvar?] [v any/c]) boolean?]{ +If @racket[mv] is currently @tech{empty}, @racket[mvar-try-put!] @tech[#:key "full"]{fills} it and returns @racket[#t]. Otherwise, returns @racket[#f]. + +@(mvar-examples + (define mv (make-mvar)) + mv + (eval:check (mvar-try-put! mv 1) #t) + mv + (eval:check (mvar-try-put! mv 2) #f) + mv)} + +@defproc[(mvar-put!-evt [mv mvar?] [v any/c]) evt?]{ +Returns a @reftech{synchronizable event} for use with @racket[sync]. The event is @reftech{ready for synchronization} when @racket[mv] is @tech{empty}, and if the event is selected, @racket[mv] is @tech[#:key "full"]{filled} with @racket[v]. The event’s @reftech{synchronization result} is the event itself.} + +@defproc[(mvar-take! [mv mvar?] [#:enable-break? enable-break? any/c #f]) any/c]{ +Removes the value contained in @racket[mv] and returns it. If @racket[mv] is currently @tech{empty}, @racket[mvar-take!] blocks until it is @tech[#:key "full"]{filled}. + +If @racket[enable-break?] is not @racket[#f], @reftech{breaks} are explicitly enabled while waiting on @racket[mv]. If breaks are disabled when @racket[mvar-take!] is called, then either @racket[mv] is emptied or an @racket[exn:break] exception is raised, but not both. + +@(mvar-examples + (define mv (make-mvar 42)) + mv + (eval:check (mvar-take! mv) 42) + mv)} + +@defproc[(mvar-try-take! [mv mvar?] [fail failure-result/c #f]) any]{ +If @racket[mv] is currently @tech{full}, @racket[mvar-try-take!] removes its value and returns it. If @racket[mv] is currently @tech{empty}, @racket[fail] determines the result: +@itemlist[ + @item{If @racket[fail] is a procedure, it is applied to zero arguments in tail position to produce the result.} + @item{Otherwise, @racket[fail] is returned as the result.}] + +@(mvar-examples + (define mv (make-mvar 42)) + mv + (eval:check (mvar-try-take! mv) 42) + mv + (eval:check (mvar-try-take! mv) #f))} + +@defproc[(mvar-take!-evt [mv mvar?]) evt?]{ +Returns a @reftech{synchronizable event} for use with @racket[sync]. The event is @reftech{ready for synchronization} when @racket[mv] is @tech{full}. If the event is selected, @racket[mv] is @tech[#:key "empty"]{emptied}, and the removed value is the event’s @reftech{synchronization result}.} + +@defproc[(mvar-peek [mv mvar?] [#:enable-break? enable-break? any/c #f]) any/c]{ +Returns the value contained in @racket[mv]. If @racket[mv] is currently @tech{empty}, @racket[mvar-peek] blocks until it is @tech[#:key "full"]{filled}. + +If @racket[enable-break?] is not @racket[#f], @reftech{breaks} are explicitly enabled while waiting on @racket[mv]. If breaks are disabled when @racket[mvar-peek] is called, then either @racket[mv] is emptied or an @racket[exn:break] exception is raised, but not both. + +@(mvar-examples + (define mv (make-mvar 42)) + (eval:check (mvar-peek mv) 42) + mv + (eval:check (mvar-peek mv) 42)) + +Note that @racket[mvar-take!] followed immediately by a use of @racket[mvar-put!] to replace the taken value is @emph{not} equivalent to @racket[mvar-peek]: since @racket[mvar-take!] @tech[#:key "empty"]{empties} the M-var, another thread may @tech[#:key "full"]{fill} it with a different value before the removed value can be replaced. In comparison, @racket[mvar-peek] does not remove the value from the M-var, so it is guaranteed to be atomic. Additionally, a call to @racket[mvar-peek] is guaranteed to return as soon as the M-var is filled, while @racket[mvar-take!] is not; see @secref["ordering-and-fairness"].} + +@defproc[(mvar-try-peek [mv mvar?] [fail failure-result/c #f]) any]{ +If @racket[mv] is currently @tech{full}, @racket[mvar-try-peek] returns its value. If @racket[mv] is currently @tech{empty}, @racket[fail] determines the result in the same was as for @racket[mvar-try-take!]. + +@(mvar-examples + (define mv (make-mvar 42)) + (eval:check (mvar-try-peek mv) 42) + (eval:check (mvar-take! mv) 42) + (eval:check (mvar-try-peek mv) #f))} + +@defproc[(mvar-peek-evt [mv mvar?]) evt?]{ +Returns a @reftech{synchronizable event} for use with @racket[sync]. The event is @reftech{ready for synchronization} when @racket[mv] is @tech{full}, and its value is the event’s @reftech{synchronization result}.} + +@defproc[(mvar-empty? [mv mvar?]) boolean?]{ +Returns @racket[#t] if @racket[mv] is currently @tech{empty}, otherwise returns @racket[#f]. + +This operation is provided for completeness, but note that if @racket[mv] has multiple readers, the result of this function could become out of date the moment it returns. It is therefore very rarely the right choice, and it is almost always better to use @racket[mvar-try-put!], @racket[mvar-try-take!], or @racket[mvar-try-peek], instead.} + +@defproc[(mvar-empty-evt [mv mvar?]) evt?]{ +Returns a @reftech{synchronizable event} for use with @racket[sync]. The event is @reftech{ready for synchronization} when @racket[mv] is @tech{empty}, and its @reftech{synchronization result} is the event itself. + +Like @racket[mvar-empty?], this operation should be used very carefully: even if the event is selected, another thread might fill @racket[mv] the instant that @racket[sync] returns, so it is almost always better to use @racket[mvar-put!-evt], instead. However, in programs where @racket[mv] only has a single writer, it can rarely be useful, so it is provided for completeness.} + +@section{Contracts} + +@defproc[(mvar/c [in-ctc contract?] [out-ctc contract? in-ctc]) contract?]{ +Returns a @reftech{contract} that recognizes @tech{M-vars}. Values written to the M-var must match @racket[in-ctc], and values read from the M-var must match @racket[out-ctc]. Usually, @racket[in-ctc] and @racket[out-ctc] are the same (which is the default if @racket[out-ctc] is not provided), but supplying @racket[none/c] for one of the arguments can be useful to restrict the client of the contract to reading from or writing to the M-var. + +If @racket[in-ctc] and @racket[out-ctc] are both @reftech{chaperone contracts}, the result will be a chaperone contract. Otherwise, the result will be an @reftech{impersonator contract}. + +@(mvar-examples + (define/contract mv (mvar/c exact-integer?) (make-mvar)) + (eval:error (mvar-put! mv 'not-an-integer)))} + +@section{Chaperones and Impersonators} + +@defproc[(impersonate-mvar [mv mvar?] + [#:get get-proc (or/c (-> any/c any/c) #f) #f] + [#:put put-proc (or/c (-> any/c any/c) #f) #f] + [prop impersonator-property?] + [prop-val any/c] + ... ...) + mvar?]{ +Returns an @reftech{impersonator} of @racket[mv]. + +If @racket[get-proc] is not @racket[#f], the result of each use of @racket[mvar-take!] or @racket[mvar-peek] on the impersonator is redirected through @racket[get-proc], which must produce a replacement value. Likewise, if @racket[put-proc] is not @racket[#f], the value stored by each use of @racket[mvar-put!] is redirected through @racket[put-proc]. + +Pairs of @racket[prop] and @racket[prop-val] (the number of by-position arguments to @racket[impersonate-mvar] must be odd) add or override @reftech{impersonator property} values of @racket[mv].} + +@defproc[(chaperone-mvar [mv mvar?] + [#:get get-proc (or/c (-> any/c any/c) #f) #f] + [#:put put-proc (or/c (-> any/c any/c) #f) #f] + [prop impersonator-property?] + [prop-val any/c] + ... ...) + mvar?]{ +Like @racket[impersonate-mvar], but produces a @reftech{chaperone} of @racket[mv], and the @racket[get-proc] and @racket[put-proc] procedures must return chaperones of their arguments.} + +@generate-bibliography[] diff --git a/mvar-lib/data/mvar.rkt b/mvar-lib/data/mvar.rkt new file mode 100644 index 0000000..6c3fcc4 --- /dev/null +++ b/mvar-lib/data/mvar.rkt @@ -0,0 +1,327 @@ +#lang racket/base + +(require racket/contract + "mvar/private/util/contract.rkt") + +(provide (contract-out + [mvar? predicate/c] + [make-mvar (case-> (-> mvar?) + (-> any/c mvar?))] + [mvar-put! (->* [mvar? any/c] [#:enable-break? any/c] void?)] + [mvar-try-put! (-> mvar? any/c boolean?)] + [mvar-put!-evt (-> mvar? any/c evt?)] + [mvar-take! (->* [mvar?] [#:enable-break? any/c] any/c)] + [mvar-try-take! (->* [mvar?] [failure-result/c] any)] + [mvar-take!-evt (-> mvar? evt?)] + [mvar-peek (->* [mvar?] [#:enable-break? any/c] any/c)] + [mvar-try-peek (->* [mvar?] [failure-result/c] any)] + [mvar-peek-evt (-> mvar? evt?)] + [mvar-empty? (-> mvar? boolean?)] + [mvar-empty-evt (-> mvar? evt?)] + + [impersonate-mvar impersonate-mvar/c] + [chaperone-mvar impersonate-mvar/c] + [mvar/c (->* [contract?] [contract?] contract?)])) + +(define no-value (gensym 'no-value)) + +;; ----------------------------------------------------------------------------- +;; mvar + +;; An mvar is implemented as a mutable cell combined with two semaphores and a +;; channel. The semaphores are waited on by threads trying to take or put, and +;; the channel is waited on by threads trying to peek. +;; +;; Ordinary takes and puts are fairly straightforward. When a thread wants to +;; take a value out of the mvar, it decrements the take semaphore, swaps the +;; value in the cell with #f, and increments the put semaphore. Likewise, when +;; a thread wants to put a value into the mvar, it decrements the put semaphore, +;; mutates the cell, and increments the take semaphore. This means that the +;; semaphore counters are always either 0 or 1, and they are never both 1 at the +;; same time (but are briefly zero while an exchange is occurring). +;; +;; “Peeking” could be implemented by simply taking the value and immediately +;; putting it back, but this creates the possibility for a different value to be +;; put into the mvar before the peeked value can be returned. Therefore, we +;; implement a separate peeking operation as a primitive, as in Haskell. In +;; addition to preventing the aforementioned scenario, all threads blocked on a +;; peek operation are guaranteed to be woken up when a value is put into the +;; mvar, before any other thread has a chance to take the value out again. This +;; makes peeking useful in single writer, multiple readers scenarios, since all +;; peeking threads are woken up at the same time. +;; +;; When a thread peeks at an mvar, it starts by polling the take semaphore in +;; order to check if a value is already there, but if it isn’t, it blocks on a +;; channel. When a thread puts a value into an mvar, it also puts the value into +;; the channel until there aren’t any more threads waiting on it before it +;; increments the take semaphore. +(struct mvar ([value #:mutable] take-sem put-sem peek-chan) + #:property prop:custom-write + (λ (self out mode) + (define v (mvar-try-peek self no-value)) + (if (eq? v no-value) + (write-string "#" out) + (fprintf out "#" v)))) + +(define make-mvar + (case-lambda + [() + (mvar #f + (make-semaphore) + (make-semaphore 1) + (make-channel))] + [(v) + (define mv (make-mvar)) + (mvar-put! mv v) + mv])) + +(define (do-put mv v) + (set-mvar-value! mv v) + (let loop () + (sync/timeout 0 (handle-evt (channel-put-evt (mvar-peek-chan mv) v) + (λ (evt) (loop))))) + (semaphore-post (mvar-take-sem mv))) + +(define (mvar-put! mv v #:enable-break? [enable-break? #f]) + (define v* (apply-mvar-put-proj mv v)) + (define wait (if (or enable-break? (break-enabled)) + semaphore-wait/enable-break + semaphore-wait)) + (parameterize-break #f + (wait (mvar-put-sem mv)) + (do-put mv v*))) + +(define (mvar-try-put! mv v) + (define v* (apply-mvar-put-proj mv v)) + (parameterize-break #f + (if (semaphore-try-wait? (mvar-put-sem mv)) + (begin + (do-put mv v*) + #t) + #f))) + +(define (mvar-put!-evt mv v) + (define v* (apply-mvar-put-proj mv v)) + (define evt (wrap-evt (mvar-put-sem mv) + (λ (sem) + (do-put mv v*) + evt))) + evt) + +(define (do-take mv) + (define v (mvar-value mv)) + (set-mvar-value! mv #f) + (semaphore-post (mvar-put-sem mv)) + v) + +(define (mvar-take! mv #:enable-break? [enable-break? #f]) + (define wait (if (or enable-break? (break-enabled)) + semaphore-wait/enable-break + semaphore-wait)) + (apply-mvar-get-proj + mv + (parameterize-break #f + (wait (mvar-take-sem mv)) + (do-take mv)))) + +(define (mvar-try-take! mv [fail #f]) + (define v (parameterize-break #f + (if (semaphore-try-wait? (mvar-take-sem mv)) + (do-take mv) + no-value))) + (if (eq? v no-value) + (get-failure-result fail) + (apply-mvar-get-proj mv v))) + +(define (mvar-take!-evt mv) + (handle-evt (wrap-evt (mvar-take-sem mv) + (λ (sem) (do-take mv))) + (λ (v) (apply-mvar-get-proj mv v)))) + +(define (do-peek mv) + (define v (mvar-value mv)) + (semaphore-post (mvar-take-sem mv)) + v) + +(define (mvar-peek-evt mv) + (handle-evt (choice-evt (mvar-peek-chan mv) + (wrap-evt (mvar-take-sem mv) (λ (sem) (do-peek mv)))) + (λ (v) (apply-mvar-get-proj mv v)))) + +(define (mvar-peek mv #:enable-break? [enable-break? #f]) + ((if enable-break? sync/enable-break sync) + (mvar-peek-evt mv))) + +(define (mvar-try-peek mv [fail #f]) + (define v (parameterize-break #f + (if (semaphore-try-wait? (mvar-take-sem mv)) + (do-peek mv) + no-value))) + (if (eq? v no-value) + (get-failure-result fail) + (apply-mvar-get-proj mv v))) + +(define (mvar-empty? mv) + (eq? (mvar-try-peek mv no-value) no-value)) + +;; The ability to block until an mvar is empty, rather than simply block on +;; putting a value into the mvar, may seem somewhat unusual. Indeed, Haskell +;; does not provide any such operation. But in fact it can be quite useful in +;; combination with Racket’s synchronizable events system, as it can be used as +;; as signal in an event loop that the mvar is ready to be refilled, and the +;; event loop can spend its time working on other things until that happens. +(define (mvar-empty-evt mv) + (semaphore-peek-evt (mvar-put-sem mv))) + +(define (get-failure-result fail) + (if (procedure? fail) + (fail) + fail)) + +;; ----------------------------------------------------------------------------- +;; chaperones and impersonators + +;; To implement chaperones and impersonators for mvars, get and put +;; projections are attached to mvar values as impersonator properties. +;; Primitive operations on mvars extract and apply the attached +;; projections as appropriate using `apply-mvar-put-proj` and/or +;; `apply-mvar-get-proj`. + +(define-values [impersonator-prop:mvar-get-proj + has-mvar-get-proj? + get-mvar-get-proj] + (make-impersonator-property 'mvar-get-proj)) +(define-values [impersonator-prop:mvar-put-proj + has-mvar-put-proj? + get-mvar-put-proj] + (make-impersonator-property 'mvar-put-proj)) + +(define (apply-mvar-get-proj mv v) + (define get-proj (get-mvar-get-proj mv #f)) + (if get-proj + (get-proj v) + v)) +(define (apply-mvar-put-proj mv v) + (define put-proj (get-mvar-put-proj mv #f)) + (if put-proj + (put-proj v) + v)) + +(define (wrap-mvar wrap-proc mv props #:get get-proc #:put put-proc) + (let* ([props (if get-proc + (list* impersonator-prop:mvar-get-proj + (let ([prev-get-proc (get-mvar-get-proj mv #f)]) + (if prev-get-proc + (λ (v) (get-proc (prev-get-proc v))) + get-proc)) + props) + props)] + [props (if put-proc + (list* impersonator-prop:mvar-put-proj + (let ([prev-put-proc (get-mvar-put-proj mv #f)]) + (if prev-put-proc + (λ (v) (prev-put-proc (put-proc v))) + put-proc)) + props) + props)]) + (apply wrap-proc mv struct:mvar props))) + +(define (impersonate-mvar mv #:get [get-proc #f] #:put [put-proc #f] . props) + (wrap-mvar impersonate-struct mv get-proc put-proc props)) +(define (chaperone-mvar mv #:get [get-proc #f] #:put [put-proc #f] . props) + (define ((make-checked-chaperone-proc proc) a) + (define b (proc a)) + (unless (chaperone-of? b a) + (raise-arguments-error '|mvar chaperone| + "non-chaperone result;\n received a value that is not a chaperone of the original value" + "value" a + "non-chaperone value" b)) + b) + (wrap-mvar chaperone-struct + mv + props + #:get (and get-proc (make-checked-chaperone-proc get-proc)) + #:put (and put-proc (make-checked-chaperone-proc put-proc)))) + +(define impersonate-mvar/c + (->* [mvar?] + [#:get (or/c (-> any/c any/c) #f) + #:put (or/c (-> any/c any/c) #f)] + #:rest impersonator-properties/c + mvar?)) + +;; ----------------------------------------------------------------------------- +;; mvar/c + +(define (make-mvar-contract-property build-contract-property wrap-mvar) + (define ((lift-relation <=?) a b) + (and (mvar-contract? b) + (<=? (mvar-contract-put-ctc a) + (mvar-contract-put-ctc b)) + (or (and (not (mvar-contract-get-ctc a)) + (not (mvar-contract-get-ctc b))) + (<=? (or (mvar-contract-put-ctc a) + (mvar-contract-get-ctc a)) + (or (mvar-contract-put-ctc b) + (mvar-contract-get-ctc b)))))) + + (build-contract-property + #:name + (λ (self) + (define put-ctc (mvar-contract-put-ctc self)) + (define get-ctc (mvar-contract-get-ctc self)) + (if get-ctc + (build-compound-type-name 'mvar/c put-ctc get-ctc) + (build-compound-type-name 'mvar/c put-ctc))) + #:first-order (λ (self) mvar?) + #:stronger (lift-relation contract-stronger?) + #:equivalent (lift-relation contract-equivalent?) + #:late-neg-projection + (λ (self) + (define put-proc (get/build-late-neg-projection (mvar-contract-put-ctc self))) + (define get-ctc (mvar-contract-get-ctc self)) + (define get-proc (if get-ctc (get/build-late-neg-projection get-ctc) put-proc)) + (λ (blame) + (define (add-context blame swap?) + (blame-add-context blame "the content of" #:swap? swap?)) + (build-pos/neg-val-projection + (λ () (get-proc (blame-add-context blame "a value read from"))) + (λ () (put-proc (blame-add-context blame "a value written to" #:swap? #t))) + (λ (get-proj put-proj) + (λ (val neg-party) + (unless (mvar? val) + (raise-blame-error + blame val #:missing-party neg-party + (list 'expected: "mvar?" 'given: "~e") val)) + + (define blame+neg-party (cons blame neg-party)) + (wrap-mvar + val + #:get (λ (val) + (with-contract-continuation-mark blame+neg-party + (get-proj val neg-party))) + #:put (λ (val) + (with-contract-continuation-mark blame+neg-party + (put-proj val neg-party))) + impersonator-prop:contracted self + impersonator-prop:blame blame+neg-party)))))))) + +(struct mvar-contract (put-ctc get-ctc) + #:property prop:custom-print-quotable 'never + #:property prop:custom-write contract-custom-write-property-proc) +(struct impersonator-mvar-contract mvar-contract () + #:property prop:contract + (make-mvar-contract-property build-contract-property impersonate-mvar)) +(struct chaperone-mvar-contract mvar-contract () + #:property prop:chaperone-contract + (make-mvar-contract-property build-chaperone-contract-property chaperone-mvar)) + +(define (mvar/c put-ctcish [get-ctcish no-value]) + (define put-ctc (coerce-contract 'mvar/c put-ctcish)) + (define get-ctc (if (eq? get-ctcish no-value) + #f + (coerce-contract 'mvar/c get-ctcish))) + (if (and (chaperone-contract? put-ctc) + (or (not get-ctc) (chaperone-contract? get-ctc))) + (chaperone-mvar-contract put-ctc get-ctc) + (impersonator-mvar-contract put-ctc get-ctc))) diff --git a/mvar-lib/data/mvar/private/util/contract.rkt b/mvar-lib/data/mvar/private/util/contract.rkt new file mode 100644 index 0000000..8e85392 --- /dev/null +++ b/mvar-lib/data/mvar/private/util/contract.rkt @@ -0,0 +1,73 @@ +#lang racket/base + +(require racket/contract + racket/match) + +(provide build-pos/neg-val-projection + impersonator-properties/c) + +;; Wraps `contract-pos/neg-doubling` in an API that doesn’t make me want to die. +(define (build-pos/neg-val-projection pos-thunk neg-thunk make-val-proj) + (define-values [filled? maybe-pos maybe-neg] + (contract-pos/neg-doubling (pos-thunk) (neg-thunk))) + (cond + [filled? + (make-val-proj maybe-pos maybe-neg)] + [else + (define val-proj + (λ (val neg-party) + (define proj (make-val-proj (maybe-pos) (maybe-neg))) + (set! val-proj proj) + (proj val neg-party))) + (λ (val neg-party) + (val-proj val neg-party))])) + +;; Like (flat-rec-contract impersonator-properties/c +;; '() (cons/c impersonator-property? (cons/c any/c impersonator-properties/c))) +;; but provides better error messages. +(define impersonator-properties/c + (let () + (define key-proc (get/build-late-neg-projection (coerce-contract 'impersonator-properties/c impersonator-property?))) + (make-flat-contract + #:list-contract? #t + #:name '(pairsof impersonator-property? any/c) + #:first-order + (λ (v) + (and (list? v) + (let loop ([vs v]) + (match vs + ['() #t] + [(list* k _ vs) + (and (impersonator-property? k) (loop vs))] + [_ #f])))) + #:late-neg-projection + (λ (blame) + (λ (val neg-party) + (unless (list? val) + (raise-blame-error + blame val #:missing-party neg-party + '(expected: "list?" given: "~e") val)) + + (define (check-prop k) + (unless (impersonator-property? k) + (raise-blame-error + blame k #:missing-party neg-party + '(expected: "impersonator-property?" given: "~e") k))) + + (let loop ([vs val]) + (match vs + ['() (void)] + [(list k) + (raise-blame-error + blame val #:missing-party neg-party + '("impersonator property does not have a value (i.e. an odd number of elements were given)\n" + " impersonator property: ~e") + k)] + [(list* k v vs) + (unless (impersonator-property? k) + (raise-blame-error + (blame-add-context blame "an element of") + k #:missing-party neg-party + '(expected: "impersonator-property?" given: "~e") k)) + (loop vs)])) + val))))) diff --git a/mvar-lib/info.rkt b/mvar-lib/info.rkt new file mode 100644 index 0000000..44b5169 --- /dev/null +++ b/mvar-lib/info.rkt @@ -0,0 +1,8 @@ +#lang info + +(define version "1.0") + +(define collection 'multi) + +(define deps '("base")) +(define build-deps '()) diff --git a/mvar-test/info.rkt b/mvar-test/info.rkt new file mode 100644 index 0000000..a194633 --- /dev/null +++ b/mvar-test/info.rkt @@ -0,0 +1,11 @@ +#lang info + +(define version "1.0") + +(define collection 'multi) + +(define deps + '("base")) +(define build-deps + '(["mvar-lib" #:version "1.0"] + "rackunit-lib")) diff --git a/mvar-test/tests/data/mvar.rkt b/mvar-test/tests/data/mvar.rkt new file mode 100644 index 0000000..5524e10 --- /dev/null +++ b/mvar-test/tests/data/mvar.rkt @@ -0,0 +1,85 @@ +#lang racket/base + +(require data/mvar + racket/contract + rackunit) + +(check-equal? (mvar-empty? (make-mvar)) #t) +(check-equal? (mvar-empty? (make-mvar 1)) #f) + +(check-equal? (mvar-take! (make-mvar 1)) 1) +(check-equal? (mvar-try-take! (make-mvar 1)) 1) +(check-equal? (mvar-try-take! (make-mvar)) #f) +(check-equal? (mvar-try-take! (make-mvar) 'fail) 'fail) +(check-equal? (mvar-try-take! (make-mvar) (λ () 'fail)) 'fail) + +(check-equal? (mvar-peek (make-mvar 1)) 1) +(check-equal? (mvar-try-peek (make-mvar 1)) 1) +(check-equal? (mvar-try-peek (make-mvar)) #f) +(check-equal? (mvar-try-peek (make-mvar) 'fail) 'fail) +(check-equal? (mvar-try-peek (make-mvar) (λ () 'fail)) 'fail) + +(check-equal? (mvar-put! (make-mvar) 1) (void)) +(check-equal? (mvar-try-put! (make-mvar) 1) #t) +(check-equal? (mvar-try-put! (make-mvar 1) 2) #f) + +(test-case + "mvar-peek completes before mvar-take!" + (define mv1 (make-mvar)) + (define mv2 (make-mvar)) + (define mv3 (make-mvar)) + (for ([i (in-range 100)]) + (thread (λ () (mvar-put! mv2 (mvar-take! mv1))))) + (thread (λ () (mvar-put! mv3 (mvar-peek mv1)))) + (sync (system-idle-evt)) ; ensure peeker is waiting + (mvar-put! mv1 10) + (check-equal? (mvar-peek mv2) 10) + (check-equal? (mvar-peek mv3) 10)) + +(test-case + "threads are garbage collected if blocked indefinitely" + (define exec (make-will-executor)) + (let () + (define mv (make-mvar)) + (will-register exec + (thread (λ () (mvar-take! mv))) + (λ (t) 'dead)) + (will-register exec + (thread (λ () (mvar-peek mv))) + (λ (t) 'dead))) + (let () + (define mv (make-mvar 1)) + (will-register exec + (thread (λ () (mvar-put! mv 2))) + (λ (t) 'dead))) + + (define (execute-one) + (let loop ([i 0]) + (if (>= i 10) + (error 'execute-one "thread still alive after 10 collections") + (or (will-try-execute exec) + (begin + (collect-garbage (if (< i 2) 'minor 'major)) + (loop (add1 i))))))) + + (check-equal? (execute-one) 'dead) + (check-equal? (execute-one) 'dead) + (check-equal? (execute-one) 'dead)) + +(define ((exn?-blaming which) exn) + (and (exn:fail:contract:blame? exn) + (let ([b (exn:fail:contract:blame-object exn)]) + (equal? (blame-positive b) which)))) + +(test-begin + (define mv (make-mvar)) + (define mv+c (contract (mvar/c exact-integer?) mv 'pos 'neg)) + (check-equal? (mvar-put! mv+c 10) (void)) + (check-equal? (mvar-peek mv+c) 10) + (check-equal? (mvar-take! mv+c) 10) + (check-exn (exn?-blaming 'neg) (λ () (mvar-put! mv+c 'not-an-integer))) + (check-equal? (mvar-empty? mv+c) #t) + (mvar-put! mv 'not-an-integer) + (check-exn (exn?-blaming 'pos) (λ () (mvar-peek mv+c))) + (check-exn (exn?-blaming 'pos) (λ () (mvar-take! mv+c))) + (check-equal? (mvar-empty? mv+c) #t)) diff --git a/mvar/info.rkt b/mvar/info.rkt new file mode 100644 index 0000000..de86137 --- /dev/null +++ b/mvar/info.rkt @@ -0,0 +1,15 @@ +#lang info + +(define version "1.0") + +(define collection 'multi) + +(define deps + '("base" + ["mvar-doc" #:version "1.0"] + ["mvar-lib" #:version "1.0"])) +(define build-deps '()) + +(define implies + '("mvar-doc" + "mvar-lib"))