Changeset 36945 in project


Ignore:
Timestamp:
11/30/18 18:49:16 (13 days ago)
Author:
kon
Message:

optional almost

Location:
release/5/synch/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/synch/trunk/critical-region.scm

    r36034 r36945  
    11;;;; critical-region.scm
    22;;;; Kon Lovett, Feb '18
     3
     4;;Issues
     5;;
     6;;- your kidding?
     7
     8#|
     9=== Critical Regions
     10
     11==== Usage
     12
     13<enscript language=scheme>
     14(import critical-region)
     15</enscript>
     16
     17Evaluated under {{(disable-interrupts)}}.
     18
     19==== critical-region
     20
     21<syntax>(critical-region EXPR ...) -> *</syntax>
     22
     23Evaluates {{EXPR ...}} w/o interrupts.
     24
     25==== apply-critical-region
     26
     27<procedure>(apply-critical-region PROC ARG0 ...) -> *</procedure>
     28
     29Evaluates {{(apply PROC' ARG0' ...')}} w/o interrupts, where {{PROC' ARG0'
     30...'}} are the result of the evaluation of {{PROC ARG0 ...}} in the caller's
     31context.
     32
     33==== call-critical-region
     34
     35<syntax>(call-critical-region THUNK) -> *</syntax>
     36
     37Evaluates {{(THUNK')}} w/o interrupts, where {{THUNK'}} is the result of the
     38evaluation of {{THUNK}} in the caller's context.
     39|#
    340
    441(declare (disable-interrupts))
     
    744
    845(;export
    9   critical-region
    10   call-critical-region
    11   apply-critical-region)
     46  interrupts-enabled?
     47  (critical-region $disable-interrupts$ $enable-interrupts$)
     48  call-critical-region apply-critical-region)
    1249
    13 (import scheme (chicken syntax))
     50(import scheme (chicken syntax) (chicken condition) (chicken foreign))
    1451
    1552;;;
    1653
     54(define (interrupts-enabled?) (foreign-value "C_interrupts_enabled" bool))
     55
     56(define $disable-interrupts$ (foreign-lambda* void () "C_disable_interrupts();"))
     57(define $enable-interrupts$ (foreign-lambda* void () "C_enable_interrupts();"))
     58
     59;;
     60
     61;FIXME check if interrupts enabled
     62;body can invoke an exit continuation
    1763(define-syntax critical-region
    18         (syntax-rules ()
    19     ((_ body ...)
    20       (call-critical-region (lambda () body ...)) ) ) )
     64  (syntax-rules ()
     65    ((critical-region body ...)
     66      (dynamic-wind
     67        $disable-interrupts$
     68        (lambda () body ... )
     69        $enable-interrupts$ ) ) ) )
    2170
    2271(define (apply-critical-region proc . rest)
    23   (apply proc rest) )
     72  (critical-region (apply proc rest)) )
    2473
    2574(define (call-critical-region thunk)
    26   (thunk) )
     75  (critical-region (thunk)) )
     76
     77;;
     78
     79;body cannot invoke an exit continuation
     80;returns <flag> <result> where
     81;flag is #t for success & result is the single-valued result
     82;flag is #f for failure & result is the exception-condition
     83(define-syntax %wrap-critical-region
     84  (syntax-rules ()
     85    ((_ body ...)
     86      (let (
     87        (caught-something #f)
     88        (res
     89          (handle-exceptions exn
     90            ;with
     91            (begin
     92              (set! caught-something #t)
     93              exn)
     94            ;try
     95            ($disable-interrupts$)
     96            body ... )) )
     97        ($enable-interrupts$)
     98        (if caught-something
     99          (values #f res)
     100          (values #t res) ) ) ) ) )
    27101
    28102;;;
  • release/5/synch/trunk/synch.egg

    r36933 r36945  
    66 (author "[[kon lovett]]")
    77 (license "BSD")
    8  (version "3.1.0")
     8 (version "3.1.1")
    99 (dependencies
    1010  (check-errors "3.1.0")
     
    1212 (test-dependencies test miscmacros)
    1313 (components
     14  (cond-expand
     15    (expose-critical-region
     16      (extension critical-region
     17        #;(inline-file)
     18        (types-file)
     19        (csc-options "-O3" "-d2" "-local" "-no-procedure-checks") ) )
     20    (else))
    1421  (extension synch
    1522    #;(inline-file)
    1623    (types-file)
    17     (csc-options "-O3" "-d2" "-local" "-no-procedure-checks") )
    18   #;
    19   (extension critical-region
    20     #;(inline-file)
    21     (types-file)
    2224    (csc-options "-O3" "-d2" "-local" "-no-procedure-checks") ) ) )
  • release/5/synch/trunk/tests/synch-test.scm

    r36933 r36945  
    88;;;
    99
    10 (import
    11   synch
    12   srfi-18
    13   miscmacros)
     10(import synch (srfi 18) miscmacros)
    1411
    1512;;;
     13
     14(test-begin "exception synch")
     15
     16(import (chicken condition))
     17
     18(let ((mx1 (make-mutex 'mx1)))
     19  (handle-exceptions exn
     20    (test "mutex unlocked (exception)" 'not-abandoned (mutex-state mx1))
     21    (synch mx1
     22      (abort 'ca1) ) ) )
     23
     24(test-end "exception synch")
     25
     26;;;
     27
     28(test-begin "record synch")
    1629
    1730(define-record-type <foo>
     
    2538  (test "record-synch" '(1 2)
    2639    (record-synch tfoo <foo> (list (<foo>-x tfoo) (<foo>-y tfoo)))) )
     40
     41(test-end "record synch")
    2742
    2843;;; Synchronize thread access to an object
     
    93108;;
    94109
    95 #;(import critical-region)
    96 
    97 #;(test-assert (critical-region #t))
     110(cond-expand
     111  (expose-critical-region
     112    (import critical-region)
     113    (test-assert "disabled" (critical-region (not (interrupts-enabled?))))
     114    (test-assert "enabled" (interrupts-enabled?))
     115    (handle-exceptions exn
     116      (test-assert "enabled" (interrupts-enabled?))
     117      (critical-region (abort 'foo)) ) )
     118  (else))
    98119
    99120;;;
Note: See TracChangeset for help on using the changeset viewer.