fixed a deadlock. make-rule-cml now behaves like fork-bombing (if
there are enough "bombs"). Added some cosmetics in make-rule.scm and collect-channels.scm.
This commit is contained in:
parent
7a6e3585c8
commit
6fe70b47e3
|
@ -11,8 +11,7 @@
|
||||||
(data cmd-msg-data))
|
(data cmd-msg-data))
|
||||||
|
|
||||||
(define (print-info tuid event name)
|
(define (print-info tuid event name)
|
||||||
(display ">>> ") (display tuid) (display " : ")
|
(format (current-error-port) ">>> ~a : ~a [~a]~%" tuid event name))
|
||||||
(display event) (display " [") (display name) (display "]") (newline))
|
|
||||||
|
|
||||||
(define (no-modify msg) msg)
|
(define (no-modify msg) msg)
|
||||||
(define (always msg) #t)
|
(define (always msg) #t)
|
||||||
|
@ -25,12 +24,7 @@
|
||||||
(cml-sync-ch/send tmp-ch (thread-uid (current-thread)))
|
(cml-sync-ch/send tmp-ch (thread-uid (current-thread)))
|
||||||
(let cond-sink-lp ((msg (cml-sync-ch/receive in)))
|
(let cond-sink-lp ((msg (cml-sync-ch/receive in)))
|
||||||
(if (pred msg)
|
(if (pred msg)
|
||||||
; (begin
|
(cml-sync-ch/send out (modify msg)))
|
||||||
; (print-info (thread-uid (current-thread))
|
|
||||||
; "cond-sink, forward" (symbol->string name))
|
|
||||||
(cml-sync-ch/send out (modify msg)))
|
|
||||||
; (print-info (thread-uid (current-thread))
|
|
||||||
; "cond-sink, shredder" (symbol->string name)))
|
|
||||||
(cond-sink-lp (cml-sync-ch/receive in))))
|
(cond-sink-lp (cml-sync-ch/receive in))))
|
||||||
name)
|
name)
|
||||||
(cml-sync-ch/receive tmp-ch)))
|
(cml-sync-ch/receive tmp-ch)))
|
||||||
|
@ -44,13 +38,7 @@
|
||||||
(cml-sync-ch/send tmp-ch (thread-uid (current-thread)))
|
(cml-sync-ch/send tmp-ch (thread-uid (current-thread)))
|
||||||
(let cond-tee-lp ((msg (cml-sync-ch/receive in)))
|
(let cond-tee-lp ((msg (cml-sync-ch/receive in)))
|
||||||
(if (pred msg)
|
(if (pred msg)
|
||||||
; (begin
|
|
||||||
; (print-info (thread-uid (current-thread))
|
|
||||||
; "cond-tee, default" (symbol->string name))
|
|
||||||
(cml-sync-ch/send out (modify msg))
|
(cml-sync-ch/send out (modify msg))
|
||||||
; (begin
|
|
||||||
; (print-info (thread-uid (current-thread))
|
|
||||||
; "cond-tee, alternate" (symbol->string name))
|
|
||||||
(cml-sync-ch/send alt msg))
|
(cml-sync-ch/send alt msg))
|
||||||
(cond-tee-lp (cml-sync-ch/receive in))))
|
(cond-tee-lp (cml-sync-ch/receive in))))
|
||||||
name)
|
name)
|
||||||
|
@ -62,8 +50,10 @@
|
||||||
(let* ((id (tee from-sink to-head))
|
(let* ((id (tee from-sink to-head))
|
||||||
(tag-msg (lambda (msg) (make-tagged-msg id msg)))
|
(tag-msg (lambda (msg) (make-tagged-msg id msg)))
|
||||||
(pred (lambda (tmsg) (eq? (tagged-msg-tag tmsg) id))))
|
(pred (lambda (tmsg) (eq? (tagged-msg-tag tmsg) id))))
|
||||||
(cond-tee pred tagged-msg-stripped from-head out to-sink 'tail-element-switch)
|
(cond-tee pred tagged-msg-stripped from-head out to-sink
|
||||||
(cond-tee always tag-msg in to-head #f 'tail-element-insert)
|
(string->symbol (string-append "tail-switch " (number->string id))))
|
||||||
|
(cond-tee always tag-msg in to-head #f
|
||||||
|
(string->symbol (string-append "tail-insert " (number->string id))))
|
||||||
id))
|
id))
|
||||||
|
|
||||||
(define-enumerated-type collect-cmd :collect-cmd
|
(define-enumerated-type collect-cmd :collect-cmd
|
||||||
|
@ -85,21 +75,14 @@
|
||||||
(spawn
|
(spawn
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(cml-sync-ch/send id-res-ch (thread-uid (current-thread)))
|
(cml-sync-ch/send id-res-ch (thread-uid (current-thread)))
|
||||||
(sink head-out head-in)
|
; (sink head-out head-in)
|
||||||
(let head-element-lp ((from-tail head-in)
|
(let head-element-lp ((from-tail head-in)
|
||||||
(to-tail head-out))
|
(to-tail head-out))
|
||||||
(let* ((->cmd-out (lambda (msg)
|
(let* ((forward-msg (lambda (ch msg async?)
|
||||||
; (print-info (thread-uid (current-thread))
|
(if async?
|
||||||
; "head-element, ->cmd-out"
|
(cml-async-ch/send-async ch (modify msg))
|
||||||
; (symbol->string name))
|
(cml-sync-ch/send ch (modify msg)))
|
||||||
(cml-sync-ch/send cmd-out (modify msg))
|
(cons from-tail to-tail)))
|
||||||
(cons from-tail to-tail)))
|
|
||||||
(->to-tail (lambda (msg)
|
|
||||||
; (print-info (thread-uid (current-thread))
|
|
||||||
; "head-element, ->to-tail"
|
|
||||||
; (symbol->string name))
|
|
||||||
(cml-sync-ch/send to-tail (modify msg))
|
|
||||||
(cons from-tail to-tail)))
|
|
||||||
(new-tail-el (lambda (msg)
|
(new-tail-el (lambda (msg)
|
||||||
(let* ((chs (cmd-msg-data msg))
|
(let* ((chs (cmd-msg-data msg))
|
||||||
(new-from-tail (cml-sync-ch/make-channel))
|
(new-from-tail (cml-sync-ch/make-channel))
|
||||||
|
@ -110,19 +93,16 @@
|
||||||
(id (tail-element new-to-tail new-from-tail
|
(id (tail-element new-to-tail new-from-tail
|
||||||
from-tail to-tail
|
from-tail to-tail
|
||||||
link-in link-out)))
|
link-in link-out)))
|
||||||
; (print-info (thread-uid (current-thread))
|
(cml-async-ch/send-async tmp-ch id)
|
||||||
; "head-element, new-tail-el"
|
|
||||||
; (symbol->string name))
|
|
||||||
(cml-sync-ch/send tmp-ch id)
|
|
||||||
(cons new-from-tail new-to-tail))))
|
(cons new-from-tail new-to-tail))))
|
||||||
(chs (cml-rv/select
|
(chs (cml-rv/select
|
||||||
(cml-rv/wrap (cml-sync-ch/receive-rv cmd-in)
|
(cml-rv/wrap (cml-async-ch/receive-async-rv cmd-in)
|
||||||
(lambda (msg)
|
(lambda (msg)
|
||||||
(if (pred msg)
|
(if (pred msg)
|
||||||
(->to-tail msg)
|
(forward-msg to-tail msg #f)
|
||||||
(new-tail-el msg))))
|
(new-tail-el msg))))
|
||||||
(cml-rv/wrap (cml-sync-ch/receive-rv from-tail)
|
(cml-rv/wrap (cml-sync-ch/receive-rv from-tail)
|
||||||
(lambda (msg) (->cmd-out msg))))))
|
(lambda (msg) (forward-msg cmd-out msg #t))))))
|
||||||
(head-element-lp (car chs) (cdr chs)))))
|
(head-element-lp (car chs) (cdr chs)))))
|
||||||
name)
|
name)
|
||||||
(cml-sync-ch/receive id-res-ch)))
|
(cml-sync-ch/receive id-res-ch)))
|
||||||
|
@ -134,8 +114,8 @@
|
||||||
(cmd-out collect&reply-channel-cmd-out))
|
(cmd-out collect&reply-channel-cmd-out))
|
||||||
|
|
||||||
(define (collect&reply/make-channel)
|
(define (collect&reply/make-channel)
|
||||||
(let ((cmd-in (cml-sync-ch/make-channel))
|
(let ((cmd-in (cml-async-ch/make-async-channel))
|
||||||
(cmd-out (cml-sync-ch/make-channel))
|
(cmd-out (cml-async-ch/make-async-channel))
|
||||||
(head-in (cml-sync-ch/make-channel))
|
(head-in (cml-sync-ch/make-channel))
|
||||||
(head-out (cml-sync-ch/make-channel)))
|
(head-out (cml-sync-ch/make-channel)))
|
||||||
(head-element no-modify cmd-in cmd-out head-in head-out 'collect&reply)
|
(head-element no-modify cmd-in cmd-out head-in head-out 'collect&reply)
|
||||||
|
@ -144,8 +124,8 @@
|
||||||
(define (make-link from to)
|
(define (make-link from to)
|
||||||
(let* ((from-->to (cml-sync-ch/make-channel))
|
(let* ((from-->to (cml-sync-ch/make-channel))
|
||||||
(from<--to (cml-sync-ch/make-channel))
|
(from<--to (cml-sync-ch/make-channel))
|
||||||
(to-tmp-ch (cml-sync-ch/make-channel))
|
(to-tmp-ch (cml-async-ch/make-async-channel))
|
||||||
(from-tmp-ch (cml-sync-ch/make-channel))
|
(from-tmp-ch (cml-async-ch/make-async-channel))
|
||||||
(chs-for-to (make-cmd-msg (collect-cmd make-link)
|
(chs-for-to (make-cmd-msg (collect-cmd make-link)
|
||||||
(list from-->to from<--to to-tmp-ch)))
|
(list from-->to from<--to to-tmp-ch)))
|
||||||
(chs-for-from (make-cmd-msg (collect-cmd make-link)
|
(chs-for-from (make-cmd-msg (collect-cmd make-link)
|
||||||
|
@ -153,9 +133,19 @@
|
||||||
(cond
|
(cond
|
||||||
((and (is-send&collect-channel? from)
|
((and (is-send&collect-channel? from)
|
||||||
(is-collect&reply-channel? to))
|
(is-collect&reply-channel? to))
|
||||||
(cml-sync-ch/send (collect&reply-channel-cmd-in to) chs-for-to)
|
(collect&reply/send to chs-for-to)
|
||||||
(cml-sync-ch/send (send&collect-channel-cmd-in from) chs-for-from)
|
(send&collect/send from chs-for-from)
|
||||||
(cons (cml-sync-ch/receive from-tmp-ch) (cml-sync-ch/receive to-tmp-ch)))
|
(cml-rv/select
|
||||||
|
(cml-rv/wrap (cml-async-ch/receive-async-rv from-tmp-ch)
|
||||||
|
(lambda (id-from)
|
||||||
|
(cons id-from
|
||||||
|
(cml-rv/sync
|
||||||
|
(cml-async-ch/receive-async-rv to-tmp-ch)))))
|
||||||
|
(cml-rv/wrap (cml-async-ch/receive-async-rv to-tmp-ch)
|
||||||
|
(lambda (id-to)
|
||||||
|
(cons (cml-rv/sync (cml-async-ch/receive-async-rv
|
||||||
|
from-tmp-ch))
|
||||||
|
id-to)))))
|
||||||
(else (error "make-link: wrong type" from to)))))
|
(else (error "make-link: wrong type" from to)))))
|
||||||
|
|
||||||
(define-record-type :send&collect-channel
|
(define-record-type :send&collect-channel
|
||||||
|
@ -165,33 +155,29 @@
|
||||||
(cmd-out send&collect-channel-cmd-out))
|
(cmd-out send&collect-channel-cmd-out))
|
||||||
|
|
||||||
(define (send&collect/make-channel)
|
(define (send&collect/make-channel)
|
||||||
(let ((cmd-in (cml-sync-ch/make-channel))
|
(let ((cmd-in (cml-async-ch/make-async-channel))
|
||||||
(cmd-out (cml-sync-ch/make-channel))
|
(cmd-out (cml-async-ch/make-async-channel))
|
||||||
(head-in (cml-sync-ch/make-channel))
|
(head-in (cml-sync-ch/make-channel))
|
||||||
(head-out (cml-sync-ch/make-channel)))
|
(head-out (cml-sync-ch/make-channel)))
|
||||||
(head-element no-modify cmd-in cmd-out head-in head-out 'send&collect)
|
(head-element no-modify cmd-in cmd-out head-in head-out 'send&collect)
|
||||||
(send&collect/really-make-channel cmd-in cmd-out)))
|
(send&collect/really-make-channel cmd-in cmd-out)))
|
||||||
|
|
||||||
(define (collect&reply/receive ch)
|
(define (collect&reply/receive ch)
|
||||||
(cml-sync-ch/receive (collect&reply-channel-cmd-out ch)))
|
(cml-rv/sync
|
||||||
|
(cml-async-ch/receive-async-rv (collect&reply-channel-cmd-out ch))))
|
||||||
|
|
||||||
(define (collect&reply/receive-rv ch)
|
(define (collect&reply/receive-rv ch)
|
||||||
(cml-sync-ch/receive-rv (collect&reply-channel-cmd-out ch)))
|
(cml-async-ch/receive-async-rv (collect&reply-channel-cmd-out ch)))
|
||||||
|
|
||||||
(define (collect&reply/send ch msg)
|
(define (collect&reply/send ch msg)
|
||||||
(cml-sync-ch/send (collect&reply-channel-cmd-in ch) msg))
|
(cml-async-ch/send-async (collect&reply-channel-cmd-in ch) msg))
|
||||||
|
|
||||||
(define (collect&reply/send-rv ch msg)
|
|
||||||
(cml-sync-ch/send-rv (collect&reply-channel-cmd-in ch) msg))
|
|
||||||
|
|
||||||
(define (send&collect/send ch msg)
|
(define (send&collect/send ch msg)
|
||||||
(cml-sync-ch/send (send&collect-channel-cmd-in ch) msg))
|
(cml-async-ch/send-async (send&collect-channel-cmd-in ch) msg))
|
||||||
|
|
||||||
(define (send&collect/send-rv ch msg)
|
|
||||||
(cml-sync-ch/send-rv (send&collect-channel-cmd-in ch) msg))
|
|
||||||
|
|
||||||
(define (send&collect/receive ch)
|
(define (send&collect/receive ch)
|
||||||
(cml-sync-ch/receive (send&collect-channel-cmd-out ch)))
|
(cml-rv/sync
|
||||||
|
(cml-async-ch/receive-async-rv (send&collect-channel-cmd-out ch))))
|
||||||
|
|
||||||
(define (send&collect/receive-rv ch)
|
(define (send&collect/receive-rv ch)
|
||||||
(cml-sync-ch/receive-rv (send&collect-channel-cmd-out ch)))
|
(cml-async-ch/receive-async-rv (send&collect-channel-cmd-out ch)))
|
||||||
|
|
|
@ -65,19 +65,17 @@
|
||||||
(build-func-result rule-result-build-func))
|
(build-func-result rule-result-build-func))
|
||||||
|
|
||||||
(define (rule-make rule init-state rule-set)
|
(define (rule-make rule init-state rule-set)
|
||||||
;;
|
|
||||||
;; this could be rewritten in future
|
|
||||||
;;
|
|
||||||
;; check for unused threads -> dont start them
|
|
||||||
;;
|
|
||||||
(map (lambda (r)
|
(map (lambda (r)
|
||||||
(rule-node r (rule-set-get-listen-ch r rule-set) init-state rule-set))
|
(rule-node r (rule-set-get-listen-ch r rule-set) init-state rule-set))
|
||||||
(map car (rule-set-rules rule-set)))
|
(map car (rule-set-rules rule-set)))
|
||||||
(let* ((server (rule-set-get-listen-ch rule rule-set))
|
(let* ((server (rule-set-get-listen-ch rule rule-set))
|
||||||
(client (send&collect/make-channel))
|
(client (send&collect/make-channel))
|
||||||
(recipient (make-link client server)))
|
(link (make-link client server))
|
||||||
|
(recipient (car link)))
|
||||||
(send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
|
(send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
|
||||||
(tagged-msg-stripped (send&collect/receive client))))
|
(let ((res (tagged-msg-stripped (send&collect/receive client))))
|
||||||
|
; (send&collect/send client (make-tagged-msg recipient (rule-cmd shutdown)))
|
||||||
|
res)))
|
||||||
|
|
||||||
(define-enumerated-type rule-cmd :rule-cmd
|
(define-enumerated-type rule-cmd :rule-cmd
|
||||||
is-rule-cmd?
|
is-rule-cmd?
|
||||||
|
@ -86,6 +84,7 @@
|
||||||
rule-cmd-index
|
rule-cmd-index
|
||||||
(make link shutdown))
|
(make link shutdown))
|
||||||
|
|
||||||
|
;;; this only works if there are no duplicates in list
|
||||||
(define (position< maybe-lesser maybe-greater objects)
|
(define (position< maybe-lesser maybe-greater objects)
|
||||||
(if (null? objects)
|
(if (null? objects)
|
||||||
(error "position< has empty objects-list.")
|
(error "position< has empty objects-list.")
|
||||||
|
@ -95,7 +94,8 @@
|
||||||
((= (tagged-msg-tag maybe-lesser) current) #t)
|
((= (tagged-msg-tag maybe-lesser) current) #t)
|
||||||
((= (tagged-msg-tag maybe-greater) current) #f)
|
((= (tagged-msg-tag maybe-greater) current) #f)
|
||||||
((null? todo)
|
((null? todo)
|
||||||
(error "position< maybe-lesser or maybe-greater not found."))
|
(error "position<: maybe-lesser or maybe-greater not found."
|
||||||
|
maybe-lesser maybe-greater))
|
||||||
(else (search-objects (car todo) (cdr todo)))))))
|
(else (search-objects (car todo) (cdr todo)))))))
|
||||||
|
|
||||||
(define (rule-node/sort-msgs unsorted to-order)
|
(define (rule-node/sort-msgs unsorted to-order)
|
||||||
|
@ -104,12 +104,22 @@
|
||||||
(position< maybe-lesser maybe-greater to-order))
|
(position< maybe-lesser maybe-greater to-order))
|
||||||
unsorted (list))))
|
unsorted (list))))
|
||||||
|
|
||||||
|
;;; (define (rule-node/prereqs-results rule connect-ch recipients)
|
||||||
|
;;; (let ((unsorted-msgs (map (lambda (recipient)
|
||||||
|
;;; (let ((tmsg (make-tagged-msg recipient
|
||||||
|
;;; (rule-cmd make))))
|
||||||
|
;;; (send&collect/send connect-ch tmsg)
|
||||||
|
;;; (send&collect/receive connect-ch)))
|
||||||
|
;;; recipients)))
|
||||||
|
;;; (rule-node/sort-msgs unsorted-msgs recipients)))
|
||||||
|
|
||||||
(define (rule-node/prereqs-results rule connect-ch recipients)
|
(define (rule-node/prereqs-results rule connect-ch recipients)
|
||||||
(let ((unsorted-msgs (map (lambda (recipient)
|
(for-each (lambda (recipient)
|
||||||
(let ((tmsg (make-tagged-msg recipient
|
(let ((tmsg (make-tagged-msg recipient (rule-cmd make))))
|
||||||
(rule-cmd make))))
|
(send&collect/send connect-ch tmsg)))
|
||||||
(send&collect/send connect-ch tmsg)
|
recipients)
|
||||||
(send&collect/receive connect-ch)))
|
(let ((unsorted-msgs (map (lambda (ignore)
|
||||||
|
(send&collect/receive connect-ch))
|
||||||
recipients)))
|
recipients)))
|
||||||
(rule-node/sort-msgs unsorted-msgs recipients)))
|
(rule-node/sort-msgs unsorted-msgs recipients)))
|
||||||
|
|
||||||
|
@ -135,38 +145,31 @@
|
||||||
(make-rule-result wants-build?-result #f))))))
|
(make-rule-result wants-build?-result #f))))))
|
||||||
|
|
||||||
(define (rule-node/make-links rule connect-ch rule-set)
|
(define (rule-node/make-links rule connect-ch rule-set)
|
||||||
(let ((listen-chs (map (lambda (r)
|
(let ((listen-chs (map (lambda (prereq-rule)
|
||||||
(cdr (assq r (rule-set-rules rule-set))))
|
(cdr (assoc prereq-rule (rule-set-rules rule-set))))
|
||||||
(rule-prereqs rule))))
|
(rule-prereqs rule))))
|
||||||
(map (lambda (listen-ch)
|
(map (lambda (listen-ch)
|
||||||
(make-link connect-ch listen-ch))
|
(make-link connect-ch listen-ch))
|
||||||
listen-chs)))
|
listen-chs)))
|
||||||
|
|
||||||
(define (rule-node rule listen-ch init-state rule-set)
|
(define (rule-node rule listen-ch init-state rule-set)
|
||||||
(let ((connect-ch (send&collect/make-channel)))
|
(let* ((connect-ch (send&collect/make-channel))
|
||||||
|
(get-rcpts (lambda ()
|
||||||
|
(map car (rule-node/make-links rule connect-ch rule-set))))
|
||||||
|
(do-answer (lambda (tmsg rcpts)
|
||||||
|
(let* ((sender (tagged-msg-tag tmsg))
|
||||||
|
(cmd (tagged-msg-stripped tmsg))
|
||||||
|
(result (rule-node/make rule listen-ch connect-ch
|
||||||
|
rcpts init-state))
|
||||||
|
(reply (make-tagged-msg sender result)))
|
||||||
|
(collect&reply/send listen-ch reply)))))
|
||||||
(spawn
|
(spawn
|
||||||
(lambda ()
|
(lambda ()
|
||||||
;;
|
|
||||||
;; wait for anything on the listen-ch
|
|
||||||
;; check if it is a known command
|
|
||||||
;; if so: process this command
|
|
||||||
;; otherwise it was noise
|
|
||||||
;;
|
|
||||||
;; if its the first time the make command drops in
|
|
||||||
;; initially make the connections to every prereq-listen-ch
|
|
||||||
;;
|
|
||||||
(let node-loop ((tmsg (collect&reply/receive listen-ch))
|
(let node-loop ((tmsg (collect&reply/receive listen-ch))
|
||||||
(maybe-recipients #f))
|
(rcpts (get-rcpts)))
|
||||||
(let ((sender (tagged-msg-tag tmsg))
|
(cond
|
||||||
(cmd (tagged-msg-stripped tmsg)))
|
((eq? (rule-cmd-name (tagged-msg-stripped tmsg)) 'make)
|
||||||
(cond
|
(do-answer tmsg rcpts))
|
||||||
((eq? (rule-cmd-name cmd) 'make)
|
(else (error "rule-node: no match")))
|
||||||
(if (not maybe-recipients)
|
(node-loop (collect&reply/receive listen-ch) rcpts)))
|
||||||
(set! maybe-recipients
|
|
||||||
(rule-node/make-links rule connect-ch rule-set)))
|
|
||||||
(let ((res (rule-node/make rule listen-ch connect-ch
|
|
||||||
maybe-recipients init-state)))
|
|
||||||
(collect&reply/send listen-ch (make-tagged-msg sender res))))
|
|
||||||
((eq? (rule-cmd-name cmd) 'shutdown) (terminate-current-thread))))
|
|
||||||
(node-loop (collect&reply/receive listen-ch) maybe-recipients)))
|
|
||||||
'rule-node)))
|
'rule-node)))
|
||||||
|
|
17
packages.scm
17
packages.scm
|
@ -104,17 +104,23 @@
|
||||||
is-tagged-msg?
|
is-tagged-msg?
|
||||||
tagged-msg-tag
|
tagged-msg-tag
|
||||||
tagged-msg-stripped
|
tagged-msg-stripped
|
||||||
|
make-cmd-msg
|
||||||
|
is-cmd-msg?
|
||||||
|
cmd-msg-cmd
|
||||||
|
cmd-msg-data
|
||||||
|
print-info
|
||||||
collect&reply/make-channel
|
collect&reply/make-channel
|
||||||
send&collect/make-channel
|
send&collect/make-channel
|
||||||
is-collect&reply-channel?
|
is-collect&reply-channel?
|
||||||
is-send&collect-channel?
|
is-send&collect-channel?
|
||||||
make-link
|
make-link
|
||||||
|
collect-cmd
|
||||||
collect&reply/receive
|
collect&reply/receive
|
||||||
collect&reply/receive-rv
|
collect&reply/receive-rv
|
||||||
collect&reply/send
|
collect&reply/send
|
||||||
collect&reply/send-rv
|
; collect&reply/send-rv
|
||||||
send&collect/send
|
send&collect/send
|
||||||
send&collect/send-rv
|
; send&collect/send-rv
|
||||||
send&collect/receive
|
send&collect/receive
|
||||||
send&collect/receive-rv))
|
send&collect/receive-rv))
|
||||||
|
|
||||||
|
@ -122,10 +128,13 @@
|
||||||
(open scheme-with-scsh
|
(open scheme-with-scsh
|
||||||
finite-types
|
finite-types
|
||||||
srfi-9
|
srfi-9
|
||||||
|
big-util ; for breakpoints
|
||||||
|
let-opt ; for logging
|
||||||
threads
|
threads
|
||||||
threads-internal
|
threads-internal
|
||||||
(with-prefix rendezvous cml-rv/)
|
(with-prefix rendezvous cml-rv/)
|
||||||
(with-prefix rendezvous-channels cml-sync-ch/))
|
(with-prefix rendezvous-channels cml-sync-ch/)
|
||||||
|
(with-prefix rendezvous-async-channels cml-async-ch/))
|
||||||
(files collect-channels))
|
(files collect-channels))
|
||||||
|
|
||||||
(define-interface make-rule-interface
|
(define-interface make-rule-interface
|
||||||
|
@ -145,6 +154,8 @@
|
||||||
locks
|
locks
|
||||||
with-lock
|
with-lock
|
||||||
threads
|
threads
|
||||||
|
threads-internal
|
||||||
|
big-util ; for breakpoints
|
||||||
srfi-1
|
srfi-1
|
||||||
srfi-9
|
srfi-9
|
||||||
finite-types
|
finite-types
|
||||||
|
|
|
@ -11,37 +11,56 @@
|
||||||
(define *k-out?* #t)
|
(define *k-out?* #t)
|
||||||
(define *l-out?* #t)
|
(define *l-out?* #t)
|
||||||
|
|
||||||
(define (is-a-out? ist) (display "setting a\n") (cons *a-out?* ist))
|
(define (reset!)
|
||||||
(define (is-b-out? pa ist) (display "setting b\n") (cons *b-out?* ist))
|
(set! *a-out?* #t)
|
||||||
(define (is-c-out? pa pb ist) (display "setting c\n") (cons *c-out?* ist))
|
(set! *b-out?* #t)
|
||||||
(define (is-d-out? pa pb pc ist) (display "setting d\n") (cons *d-out?* ist))
|
(set! *c-out?* #t)
|
||||||
(define (is-e-out? pc pd ist) (display "setting e\n") (cons *e-out?* ist))
|
(set! *d-out?* #t)
|
||||||
(define (is-f-out? pa pb pc pd pe ist) (cons *f-out?* ist))
|
(set! *e-out?* #t))
|
||||||
(define (is-g-out? pa pb pc pd pe pf ist) (cons *g-out?* ist))
|
|
||||||
(define (is-h-out? pa pb pc pd pe pf pg ist) (cons *h-out?* ist))
|
|
||||||
(define (is-i-out? pa pb pc pd pe pf pg ph ist) (cons *i-out?* ist))
|
|
||||||
(define (is-j-out? pa pb pc pd pe pf pg ph pi ist) (cons *j-out?* ist))
|
|
||||||
(define (is-k-out? pa pb pc pd pe pf pg ph pi pj ist) (cons *k-out?* ist))
|
|
||||||
(define (is-l-out? pa pb pc pd pe pf pg ph pi pj pk ist) (cons *l-out?* ist))
|
|
||||||
|
|
||||||
(define (build-a b? ist) (display "a\n") (set! *a-out?* #f) (cons *a-out?* ist))
|
(define (is-a-out? ist) (display "setting a\n") (cons *a-out?* ist))
|
||||||
(define (build-b b? pa ist) (display "b\n") (set! *b-out?* #f) (cons *b-out?* ist))
|
(define (is-b-out? . args) (display "setting b\n") (cons *b-out?* (last args)))
|
||||||
(define (build-c b? pa pb ist) (display "c\n") (set! *c-out?* #f) (cons *c-out?* ist))
|
(define (is-c-out? . args) (display "setting c\n") (cons *c-out?* (last args)))
|
||||||
(define (build-d b? pa pb pc ist) (display "d\n") (set! *d-out?* #f) (cons *d-out?* ist))
|
(define (is-d-out? . args) (display "setting d\n") (cons *d-out?* (last args)))
|
||||||
(define (build-e b? pc pd ist) (display "e\n") (set! *e-out?* #f) (cons *e-out?* ist))
|
(define (is-e-out? . args) (display "setting e\n") (cons *e-out?* (last args)))
|
||||||
(define (build-f b? pa pb pc pd pe ist) (display "f\n") (set! *f-out?* #f) (cons *f-out?* ist))
|
(define (is-f-out? . args) (display "setting f\n") (cons *f-out?* (last args)))
|
||||||
(define (build-g b? pa pb pc pd pe pf ist) (display "g\n") (set! *g-out?* #f) (cons *g-out?* ist))
|
(define (is-g-out? . args) (display "setting f\n") (cons *g-out?* (last args)))
|
||||||
(define (build-h b? pa pb pc pd pe pf pg ist) (display "h\n") (set! *h-out?* #f) (cons *h-out?* ist))
|
(define (is-h-out? . args) (display "setting f\n") (cons *h-out?* (last args)))
|
||||||
(define (build-i b? pa pb pc pd pe pf pg ph ist) (display "i\n") (set! *i-out?* #f) (cons *i-out?* ist))
|
(define (is-i-out? . args) (display "setting f\n") (cons *i-out?* (last args)))
|
||||||
(define (build-j b? pa pb pc pd pe pf pg ph pi ist) (display "j\n") (set! *j-out?* #f) (cons *j-out?* ist))
|
(define (is-j-out? . args) (display "setting f\n") (cons *j-out?* (last args)))
|
||||||
(define (build-k b? pa pb pc pd pe pf pg ph pi pj ist) (display "k\n") (set! *k-out?* #f) (cons *k-out?* ist))
|
(define (is-k-out? . args) (display "setting f\n") (cons *k-out?* (last args)))
|
||||||
(define (build-l b? pa pb pc pd pe pf pg ph pi pj pk ist) (display "l\n") (set! *l-out?* #f) (cons *l-out?* ist))
|
(define (is-l-out? . args) (display "setting f\n") (cons *l-out?* (last args)))
|
||||||
|
|
||||||
(define a (make-rule (list) is-a-out? build-a))
|
(define (build-a b? . args)
|
||||||
(define b (make-rule (list a) is-b-out? build-b))
|
(display "a\n") (set! *a-out?* #f) (cons *a-out?* (last args)))
|
||||||
(define c (make-rule (list a b) is-c-out? build-c))
|
(define (build-b b? . args)
|
||||||
(define d (make-rule (list a b c) is-d-out? build-d))
|
(display "b\n") (set! *b-out?* #f) (cons *b-out?* (last args)))
|
||||||
(define e (make-rule (list c d) is-e-out? build-e))
|
(define (build-c b? . args)
|
||||||
|
(display "c\n") (set! *c-out?* #f) (cons *c-out?* (last args)))
|
||||||
|
(define (build-d b? . args)
|
||||||
|
(display "d\n") (set! *d-out?* #f) (cons *d-out?* (last args)))
|
||||||
|
(define (build-e b? . args)
|
||||||
|
(display "e\n") (set! *e-out?* #f) (cons *e-out?* (last args)))
|
||||||
|
(define (build-f b? . args)
|
||||||
|
(display "f\n") (set! *f-out?* #f) (cons *f-out?* (last args)))
|
||||||
|
(define (build-g b? . args)
|
||||||
|
(display "g\n") (set! *g-out?* #f) (cons *g-out?* (last args)))
|
||||||
|
(define (build-h b? . args)
|
||||||
|
(display "h\n") (set! *h-out?* #f) (cons *h-out?* (last args)))
|
||||||
|
(define (build-i b? . args)
|
||||||
|
(display "i\n") (set! *i-out?* #f) (cons *i-out?* (last args)))
|
||||||
|
(define (build-j b? . args)
|
||||||
|
(display "j\n") (set! *j-out?* #f) (cons *j-out?* (last args)))
|
||||||
|
(define (build-k b? . args)
|
||||||
|
(display "k\n") (set! *k-out?* #f) (cons *k-out?* (last args)))
|
||||||
|
(define (build-l b? . args)
|
||||||
|
(display "l\n") (set! *l-out?* #f) (cons *l-out?* (last args)))
|
||||||
|
|
||||||
|
;(define a (make-rule (list) is-a-out? build-a))
|
||||||
|
;(define b (make-rule (list a) is-b-out? build-b))
|
||||||
|
;(define c (make-rule (list b) is-c-out? build-c))
|
||||||
|
;(define d (make-rule (list b) is-d-out? build-d))
|
||||||
|
;(define e (make-rule (list c d) is-e-out? build-e))
|
||||||
;(define f (make-rule (list a b c d e) is-f-out? build-f))
|
;(define f (make-rule (list a b c d e) is-f-out? build-f))
|
||||||
;(define g (make-rule (list a b c d e f) is-g-out? build-g))
|
;(define g (make-rule (list a b c d e f) is-g-out? build-g))
|
||||||
;(define h (make-rule (list a b c d e f g) is-h-out? build-h))
|
;(define h (make-rule (list a b c d e f g) is-h-out? build-h))
|
||||||
|
@ -51,17 +70,33 @@
|
||||||
;(define l (make-rule (list a b c d e f g h i j k) is-l-out? build-l))
|
;(define l (make-rule (list a b c d e f g h i j k) is-l-out? build-l))
|
||||||
|
|
||||||
;(define rules (list a b c d e f g h i j k l))
|
;(define rules (list a b c d e f g h i j k l))
|
||||||
(define rules (list a b c d e))
|
;(define rules (list a b c d e))
|
||||||
|
|
||||||
(define (make-rule-set rules rule-set)
|
(define (make-rule-set rules rule-set)
|
||||||
(cond
|
(cond
|
||||||
((null? rules) rule-set)
|
((null? rules) rule-set)
|
||||||
(else (make-rule-set (cdr rules) (rule-set-add (car rules) rule-set)))))
|
(else (make-rule-set (cdr rules) (rule-set-add (car rules) rule-set)))))
|
||||||
|
|
||||||
(define rule-set (make-rule-set rules (make-empty-rule-set)))
|
(define rule-set 'unset-rule-set)
|
||||||
|
|
||||||
(rule-make e '() rule-set)
|
(define (make!)
|
||||||
(rule-make d '() rule-set)
|
(define a (make-rule (list) is-a-out? build-a))
|
||||||
(rule-make e '() rule-set)
|
(define b (make-rule (list a) is-b-out? build-b))
|
||||||
(rule-make c '() rule-set)
|
(define c (make-rule (list b) is-c-out? build-c))
|
||||||
|
(define d (make-rule (list b) is-d-out? build-d))
|
||||||
|
(define e (make-rule (list b c d) is-e-out? build-e))
|
||||||
|
(define f (make-rule (list b c d e) is-f-out? build-f))
|
||||||
|
(define g (make-rule (list b c d e f) is-g-out? build-g))
|
||||||
|
(define h (make-rule (list b c d e f g) is-h-out? build-h))
|
||||||
|
(define i (make-rule (list a b c d e f g h) is-i-out? build-i))
|
||||||
|
(define j (make-rule (list a b c d e f g h i) is-j-out? build-j))
|
||||||
|
(define k (make-rule (list a b c d e f g h i j) is-k-out? build-k))
|
||||||
|
(define l (make-rule (list a b c d e f g h i j k) is-l-out? build-l))
|
||||||
|
(define rules (list a b c d e f g h i j k l))
|
||||||
|
(reset!)
|
||||||
|
(set! rule-set (make-rule-set rules (make-empty-rule-set)))
|
||||||
|
(rule-make l '() rule-set))
|
||||||
|
;(rule-make d '() rule-set)
|
||||||
|
;(rule-make e '() rule-set)
|
||||||
|
;(rule-make c '() rule-set)
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue