;; Copyright (C) Marc Nieper-Wißkirchen (2021). All Rights Reserved. ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the "Software"), to deal in the Software without ;; restriction, including without limitation the rights to use, copy, ;; modify, merge, publish, distribute, sublicense, and/or sell copies ;; of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define-library (srfi 230) (export memory-order memory-order? make-atomic-flag atomic-flag? atomic-flag-test-and-set! atomic-flag-clear! make-atomic-box atomic-box? atomic-box-ref atomic-box-set! atomic-box-swap! atomic-box-compare-and-swap! make-atomic-fxbox atomic-fxbox? atomic-fxbox-ref atomic-fxbox-set! atomic-fxbox-swap! atomic-fxbox-compare-and-swap! atomic-fxbox+/fetch! atomic-fxbox-/fetch! atomic-fxbox-and/fetch! atomic-fxbox-ior/fetch! atomic-fxbox-xor/fetch! make-atomic-pair atomic-pair? atomic-pair-ref atomic-pair-set! atomic-pair-swap! atomic-pair-compare-and-swap! atomic-fence) (import (scheme base) (scheme case-lambda) (srfi 18) (srfi 143)) (begin ;; Internals (define lock (make-mutex)) (define-syntax lock-guard (syntax-rules () ((lock-guard . body) (dynamic-wind (lambda () (guard (c ((abandoned-mutex-exception? c) #f)) (mutex-lock! lock))) (lambda () . body) (lambda () (mutex-unlock! lock)))))) ;; Memory orders ;; Note: On an R6RS system, the following syntax and procedure would be ;; implemented as an enumeration type. (define-syntax memory-order (syntax-rules () ((memory-order symbol) 'symbol))) (define (memory-order? obj) (and (memq obj '(relaxed acquire release acquire-release sequentially-consistent)) #t)) ;; Atomic flags (define-record-type atomic-flag (%make-atomic-flag content) atomic-flag? (content atomic-flag-content atomic-flag-set-content!)) (define (make-atomic-flag) (%make-atomic-flag #f)) (define (atomic-flag-test-and-set! flag . o) (lock-guard (let ((prev (atomic-flag-content flag))) (atomic-flag-set-content! flag #t) prev))) (define (atomic-flag-clear! flag . o) (lock-guard (atomic-flag-set-content! flag #f))) ;; Atomic boxes (define-record-type atomic-box (make-atomic-box content) atomic-box? (content atomic-box-content atomic-box-set-content!)) (define (atomic-box-ref box . o) (lock-guard (atomic-box-content box))) (define (atomic-box-set! box obj . o) (lock-guard (atomic-box-set-content! box obj))) (define (atomic-box-swap! box obj . o) (lock-guard (let ((prev (atomic-box-content box))) (atomic-box-set-content! box obj) prev))) (define (atomic-box-compare-and-swap! box expected desired . o) (lock-guard (let ((actual (atomic-box-content box))) (when (eq? expected actual) (atomic-box-set-content! box desired)) actual))) ;; Atomic fixnum boxes (define-record-type atomic-fxbox (make-atomic-fxbox content) atomic-fxbox? (content atomic-fxbox-content atomic-fxbox-set-content!)) (define (atomic-fxbox-ref box . o) (lock-guard (atomic-fxbox-content box))) (define (atomic-fxbox-set! box obj . o) (lock-guard (atomic-fxbox-set-content! box obj))) (define (atomic-fxbox-swap! box obj . o) (lock-guard (let ((prev (atomic-fxbox-content box))) (atomic-fxbox-set-content! box obj) prev))) (define (atomic-fxbox-compare-and-swap! box expected desired . o) (lock-guard (let ((actual (atomic-fxbox-content box))) (when (fx=? expected actual) (atomic-fxbox-set-content! box desired)) actual))) (define (atomic-fxbox+/fetch! box n . o) (lock-guard (let ((prev (atomic-fxbox-content box))) (atomic-fxbox-set-content! box (fx+ prev n)) prev))) (define (atomic-fxbox-/fetch! box n . o) (lock-guard (let ((prev (atomic-fxbox-content box))) (atomic-fxbox-set-content! box (fx- prev n)) prev))) (define (atomic-fxbox-and/fetch! box n . o) (lock-guard (let ((prev (atomic-fxbox-content box))) (atomic-fxbox-set-content! box (fxand prev n)) prev))) (define (atomic-fxbox-ior/fetch! box n . o) (lock-guard (let ((prev (atomic-fxbox-content box))) (atomic-fxbox-set-content! box (fxior prev n)) prev))) (define (atomic-fxbox-xor/fetch! box n . o) (lock-guard (let ((prev (atomic-fxbox-content box))) (atomic-fxbox-set-content! box (fxxor prev n)) prev))) ;; Atomic pairs (define-record-type atomic-pair (make-atomic-pair car cdr) atomic-pair? (car atomic-pair-car atomic-pair-set-car!) (cdr atomic-pair-cdr atomic-pair-set-cdr!)) (define (atomic-pair-ref pair . o) (lock-guard (values (atomic-pair-car pair) (atomic-pair-cdr pair)))) (define (atomic-pair-set! pair car cdr . o) (lock-guard (atomic-pair-set-car! pair car) (atomic-pair-set-cdr! pair cdr))) (define (atomic-pair-swap! pair car cdr . o) (lock-guard (let ((prev-car (atomic-pair-car pair)) (prev-cdr (atomic-pair-cdr pair))) (atomic-pair-set-car! pair car) (atomic-pair-set-cdr! pair cdr) (values prev-car prev-cdr)))) (define (atomic-pair-compare-and-swap! pair expected-car expected-cdr desired-car desired-cdr . o) (lock-guard (let ((actual-car (atomic-pair-car pair)) (actual-cdr (atomic-pair-cdr pair))) (when (and (eq? expected-car actual-car) (eq? expected-cdr actual-cdr)) (atomic-pair-set-car! pair desired-car) (atomic-pair-set-cdr! pair desired-cdr)) (values actual-car actual-cdr)))) ;; Memory synchronization (define (atomic-fence . o) (lock-guard (if #f #f))))) ;; Local Variables: ;; mode: scheme ;; End: