;;;; critical-region.scm
;;;; Kon Lovett, Feb '18
;;Issues
;;
;;- your kidding?
#|
(cond-expand
(expose-critical-region #;(or compiling csi)
(test-group "Critical Region"
(import critical-region)
(test-assert "disabled" (critical-region (not (interrupts-enabled?))))
(test-assert "enabled" (interrupts-enabled?))
(test-assert (not (critical-region* (abort 'foo))))
(test-assert "enabled" (interrupts-enabled?))
(test 'expected (critical-region-apply (lambda (x) x) 'expected))
(test-assert (not (critical-region-call* (lambda () (abort 'foo)))))
) )
(else))
|#
#|
=== Remote Critical Region
==== Usage
(import critical-region)
==== critical-region-apply
(critical-region-apply PROC ARG0 ...) -> *
Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may exit via
continuation.
==== critical-region-call
(critical-region-call PROC) -> *
Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.
==== critical-region-apply*
(critical-region-apply PROC ARG0 ...) -> boolean *
Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may exit via
continuation.
The first value} indicates whether the 2nd value is, {{#t}}, the
single-valued result, or, {{#f}}, the captured exception condition.
==== critical-region-call*
(critical-region-call* PROC) -> boolean *
Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.
The first value} indicates whether the 2nd value is, {{#t}}, the
single-valued result, or, {{#f}}, the captured exception condition.
==== %critical-region-apply
(%critical-region-apply PROC ARG0 ...) -> *
Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may '''not'''
exit via continuation or raise an exception.
==== %critical-region-call
(%critical-region-call PROC) -> *
Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may '''not''' exit via
continuation or raise an exception.
==== %critical-region-apply*
(%critical-region-apply* PROC ARG0 ...) -> boolean *
Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may '''not'''
exit via continuation.
The first value} indicates whether the 2nd value is, {{#t}}, the
single-valued result, or, {{#f}}, the captured exception condition.
==== %critical-region-call*
(%critical-region-call* PROC) -> boolean *
Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may '''not''' exit via
continuation.
The first value} indicates whether the 2nd value is, {{#t}}, the
single-valued result, or, {{#f}}, the captured exception condition.
=== Local Critical Region
==== critical-region
(critical-region EXPR ...) -> *
Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may exit via continuation.
==== %critical-region
(%critical-region EXPR ...) -> *
Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may '''not''' exit via
continuation.
==== critical-region*
(critical-region* EXPR ...) -> *
Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may exit via continuation.
The first value} indicates whether the 2nd value is, {{#t}}, the
single-valued result, or, {{#f}}, the captured exception condition.
==== %critical-region*
(%critical-region* EXPR ...) -> *
Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may '''not''' exit via
continuation or raise an exception.
The first value} indicates whether the 2nd value is, {{#t}}, the
single-valued result, or, {{#f}}, the captured exception condition.
|#
(declare (disable-interrupts))
(module critical-region
(;export
;
interrupts-enabled?
;
critical-region-call critical-region-apply
%critical-region-call %critical-region-apply
;
critical-region-call* critical-region-apply*
%critical-region-call* %critical-region-apply*
;
(critical-region $disable-interrupts$ $enable-interrupts$)
(%critical-region $disable-interrupts$ $enable-interrupts$)
;
(critical-region* $disable-interrupts$ $enable-interrupts$)
(%critical-region* $disable-interrupts$ $enable-interrupts$))
(import scheme (chicken syntax) (chicken condition) (chicken foreign))
;;;
(define (interrupts-enabled?) (foreign-value "C_interrupts_enabled" bool))
(define $disable-interrupts$ (foreign-lambda* void () "C_disable_interrupts();"))
(define $enable-interrupts$ (foreign-lambda* void () "C_enable_interrupts();"))
;;;
;body can invoke an exit continuation
(define-syntax critical-region
(syntax-rules ()
((critical-region body ...)
(dynamic-wind
$disable-interrupts$
(lambda () body ...)
$enable-interrupts$) ) ) )
;body cannot invoke an exit continuation or raise an exception
;returns the single-valued result
(define-syntax %critical-region
(syntax-rules ()
((%critical-region body ...)
(begin
($disable-interrupts$)
(let (
(res (begin body ...)) )
($enable-interrupts$)
res ) ) ) ) )
;body can invoke an exit continuation
;returns where
;flag is #t & result is the single-valued result
;flag is #f & result is the exception-condition
(define-syntax critical-region*
(syntax-rules ()
((critical-region* body ...)
(let* (
(flag #t)
(res
(critical-region
(handle-exceptions
exn (begin (set! flag #f) exn)
body ...))) )
(values flag res) ) ) ) )
;body cannot invoke an exit continuation
;returns where
;flag is #t & result is the single-valued result
;flag is #f & result is the exception-condition
(define-syntax %critical-region*
(syntax-rules ()
((%critical-region* body ...)
(let* (
(flag #t)
(res
(%critical-region
(handle-exceptions
exn (begin (set! flag #f) exn)
body ...))) )
(values flag res) ) ) ) )
;;;
(define (critical-region-apply* proc . rest)
(critical-region* (apply proc rest)) )
(define (critical-region-call* thunk)
(critical-region* (thunk)) )
(define (critical-region-apply proc . rest)
(critical-region (apply proc rest)) )
(define (critical-region-call thunk)
(critical-region (thunk)) )
(define (%critical-region-apply* proc . rest)
(%critical-region* (apply proc rest)) )
(define (%critical-region-call* thunk)
(%critical-region* (thunk)) )
(define (%critical-region-apply proc . rest)
(%critical-region (apply proc rest)) )
(define (%critical-region-call thunk)
(%critical-region (thunk)) )
) ;module critical-region