;;;; critical-region.scm
;;;; Kon Lovett, Feb '18

;;Issues
;;
;;- your kidding?

(declare (disable-interrupts))

(module critical-region

(;export
  make-exchanger
  ;
  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)
(import (chicken syntax))
(import (chicken condition))
(import (chicken foreign))

;;;

;; SRFI-96 Mutual Exclusion

(define (make-exchanger v)
  (let ((+v+ v))
    (lambda (x)
      (let ((v +v+))
        (set! +v+ x)
        v ) ) ) )

;;

(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 <flag> <result> 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) (values flag exn))
              body ...))) )
        (values flag res) ) ) ) )

;body cannot invoke an exit continuation
;returns <flag> <result> 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) (values flag 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

#|
=== Remote Critical Region

==== Usage

<enscript language=scheme>
(import critical-region)
</enscript>

==== critical-region-apply

<procedure>(critical-region-apply PROC ARG0 ...) -> *</procedure>

Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may exit via
continuation.

==== critical-region-call

<procedure>(critical-region-call PROC) -> *</procedure>

Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.

==== critical-region-apply*

<procedure>(critical-region-apply PROC ARG0 ...) -> boolean *</procedure>

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*

<procedure>(critical-region-call* PROC) -> boolean *</procedure>

Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.

==== %critical-region-apply

<procedure>(%critical-region-apply PROC ARG0 ...) -> *</procedure>

Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may '''not'''
exit via continuation or raise an exception.

==== %critical-region-call

<procedure>(%critical-region-call PROC) -> *</procedure>

Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may '''not''' exit via
continuation or raise an exception.

==== %critical-region-apply*

<procedure>(%critical-region-apply* PROC ARG0 ...) -> boolean *</procedure>

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*

<procedure>(%critical-region-call* PROC) -> boolean *</procedure>

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

<syntax>(critical-region EXPR ...) -> *</syntax>

Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may exit via continuation.

==== %critical-region

<syntax>(%critical-region EXPR ...) -> *</syntax>

Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may '''not''' exit via
continuation.

==== critical-region*

<syntax>(critical-region* EXPR ...) -> *</syntax>

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*

<syntax>(%critical-region* EXPR ...) -> *</syntax>

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.
|#