167 lines
4.7 KiB
Scheme
167 lines
4.7 KiB
Scheme
#lang scheme
|
|
(require redex)
|
|
|
|
#|
|
|
|
|
semaphores make things much more predictable...
|
|
|
|
|#
|
|
|
|
(reduction-steps-cutoff 100)
|
|
|
|
(define-language lang
|
|
(p ((store (variable v) ...)
|
|
(semas (variable sema-count) ...)
|
|
(threads e ...)))
|
|
(sema-count number
|
|
none)
|
|
(e (set! variable e)
|
|
(begin e ...)
|
|
(semaphore variable)
|
|
(semaphore-wait e)
|
|
(semaphore-post e)
|
|
(lambda (variable) e)
|
|
(e e)
|
|
variable
|
|
(list e ...)
|
|
(cons e e)
|
|
number
|
|
(void))
|
|
(p-ctxt ((store (variable v) ...)
|
|
(semas (variable sema-count) ...)
|
|
(threads e ... e-ctxt e ...)))
|
|
(e-ctxt (e-ctxt e)
|
|
(v e-ctxt)
|
|
(cons e-ctxt e)
|
|
(cons v e-ctxt)
|
|
(list v ... e-ctxt e ...)
|
|
(set! variable e-ctxt)
|
|
(begin e-ctxt e ...)
|
|
(semaphore-wait e-ctxt)
|
|
(semaphore-post e-ctxt)
|
|
hole)
|
|
(v (semaphore variable)
|
|
(lambda (variable) e)
|
|
(list v ...)
|
|
number
|
|
(void)))
|
|
|
|
(define reductions
|
|
(reduction-relation
|
|
lang
|
|
(--> (in-hole (name c p-ctxt) (begin v e_1 e_2 e_rest ...))
|
|
(in-hole c (begin e_1 e_2 e_rest ...)))
|
|
(--> (in-hole (name c p-ctxt) (cons v_1 (list v_2s ...)))
|
|
(in-hole c (list v_1 v_2s ...)))
|
|
(--> (in-hole (name c p-ctxt) (begin v e_1))
|
|
(in-hole c e_1))
|
|
(--> (in-hole (name c p-ctxt) (begin v_1))
|
|
(in-hole c v_1))
|
|
(--> ((store
|
|
(variable_before v_before) ...
|
|
((name x variable) (name v v))
|
|
(variable_after v_after) ...)
|
|
(name semas any)
|
|
(threads
|
|
e_before ...
|
|
(in-hole (name c e-ctxt) (name x variable))
|
|
e_after ...))
|
|
((store
|
|
(variable_before v_before) ...
|
|
(x v)
|
|
(variable_after v_after) ...)
|
|
semas
|
|
(threads
|
|
e_before ...
|
|
(in-hole c v)
|
|
e_after ...)))
|
|
(--> ((store (variable_before v_before) ...
|
|
(variable_i v)
|
|
(variable_after v_after) ...)
|
|
(name semas any)
|
|
(threads
|
|
e_before ...
|
|
(in-hole (name c e-ctxt) (set! variable_i v_new))
|
|
e_after ...))
|
|
((store (variable_before v_before) ...
|
|
(variable_i v_new)
|
|
(variable_after v_after) ...)
|
|
semas
|
|
(threads
|
|
e_before ...
|
|
(in-hole c (void))
|
|
e_after ...)))
|
|
(--> ((name store any)
|
|
(semas
|
|
(variable_before v_before) ...
|
|
(variable_sema number_n)
|
|
(variable_after v_after) ...)
|
|
(threads
|
|
e_before ...
|
|
(in-hole (name c e-ctxt) (semaphore-wait (semaphore variable_sema)))
|
|
e_after ...))
|
|
(store
|
|
(semas
|
|
(variable_before v_before) ...
|
|
(variable_sema ,(if (= (term number_n) 1)
|
|
(term none)
|
|
(- (term number_n) 1)))
|
|
(variable_after v_after) ...)
|
|
(threads
|
|
e_before ...
|
|
(in-hole c (void))
|
|
e_after ...)))
|
|
(--> ((name store any)
|
|
(semas
|
|
(variable_before v_before) ...
|
|
(variable_sema number_n)
|
|
(variable_after v_after) ...)
|
|
(threads
|
|
e_before ...
|
|
(in-hole (name c e-ctxt) (semaphore-post (semaphore variable_sema)))
|
|
e_after ...))
|
|
(store
|
|
(semas
|
|
(variable_before v_before) ...
|
|
(variable_sema ,(+ (term number_n) 1))
|
|
(variable_after v_after) ...)
|
|
(threads
|
|
e_before ...
|
|
(in-hole c (void))
|
|
e_after ...)))
|
|
|
|
(--> ((name store any)
|
|
(semas
|
|
(variable_before v_before) ...
|
|
(variable_sema none)
|
|
(variable_after v_after) ...)
|
|
(threads
|
|
e_before ...
|
|
(in-hole (name c e-ctxt) (semaphore-post (semaphore variable_sema)))
|
|
e_after ...))
|
|
(store
|
|
(semas
|
|
(variable_before v_before) ...
|
|
(variable_sema 1)
|
|
(variable_after v_after) ...)
|
|
(threads
|
|
e_before ...
|
|
(in-hole c (void))
|
|
e_after ...)))))
|
|
|
|
(stepper reductions
|
|
`((store (y (list)))
|
|
(semas)
|
|
(threads (set! y (cons 1 y))
|
|
(set! y (cons 2 y)))))
|
|
|
|
(stepper reductions
|
|
`((store (y (list)))
|
|
(semas (x 1))
|
|
(threads (begin (semaphore-wait (semaphore x))
|
|
(set! y (cons 1 y))
|
|
(semaphore-post (semaphore x)))
|
|
(begin (semaphore-wait (semaphore x))
|
|
(set! y (cons 2 y))
|
|
(semaphore-post (semaphore x))))))
|