Initial import.
This commit is contained in:
jottbee
parent
52d770599b
commit
50eb6e3000
|
|
@ -0,0 +1,62 @@
|
|||
(define (cml-fork sig-ch thunk)
|
||||
(let* ((ch (cml-sync-ch/make-channel))
|
||||
(res-ch (cml-sync-ch/make-channel))
|
||||
(sig-rv (cml-sync-ch/receive-rv sig-ch))
|
||||
(process (fork thunk))
|
||||
(proc-done-rv (cml-sync-ch/receive-rv ch)))
|
||||
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let lp ()
|
||||
(cml-rv/select
|
||||
(cml-rv/wrap sig-rv
|
||||
(lambda (sig) (if (not (wait process wait/poll))
|
||||
(begin (signal-process process sig)
|
||||
(lp)))))
|
||||
(cml-rv/wrap proc-done-rv
|
||||
(lambda (res) (cml-sync-ch/send res-ch res))))))
|
||||
(format #t "cml-fork: signals (for ~a)\n" (proc:pid process)))
|
||||
|
||||
(spawn (lambda ()
|
||||
(cml-sync-ch/send ch (wait process)))
|
||||
(format #t "cml-fork: waiting (for ~a)\n" (proc:pid process)))
|
||||
|
||||
(cml-sync-ch/receive-rv res-ch)))
|
||||
|
||||
(define (cml-fork-collecting fds sig-ch thunk)
|
||||
(let* ((ch (cml-sync-ch/make-channel))
|
||||
(res-ch (cml-sync-ch/make-channel))
|
||||
(sig-rv (cml-sync-ch/receive-rv sig-ch))
|
||||
;; from scsh-0.6.6/scsh/scsh.scm
|
||||
(channels (map (lambda (ignore)
|
||||
(call-with-values temp-file-channel cons))
|
||||
fds))
|
||||
(read-ports (map car channels))
|
||||
(write-ports (map cdr channels))
|
||||
(process (fork (lambda ()
|
||||
(for-each close-input-port read-ports)
|
||||
(for-each move->fdes write-ports fds)
|
||||
(apply exec-path (thunk)))))
|
||||
(proc-done-rv (cml-sync-ch/receive-rv ch)))
|
||||
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let ((exitno (wait process)))
|
||||
(cml-sync-ch/send ch (append (list exitno)
|
||||
(map port->string read-ports)))))
|
||||
(format #t "cml-fork-collecting: waiting (for ~a)\n" (proc:pid process)))
|
||||
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(cml-rv/select
|
||||
(cml-rv/wrap sig-rv
|
||||
(lambda (sig) (if (not (wait process wait/poll))
|
||||
(begin (signal-process process sig)
|
||||
(loop)))))
|
||||
(cml-rv/wrap proc-done-rv
|
||||
(lambda (res) (cml-sync-ch/send res-ch res))))))
|
||||
(format #t "cml-fork-collecting: signals (for ~a)\n" (proc:pid process)))
|
||||
|
||||
(for-each close-output-port write-ports)
|
||||
(cml-sync-ch/receive-rv res-ch)))
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
(define-record-type :job-desc
|
||||
(make-job-desc wd env cmd)
|
||||
job-desc?
|
||||
(wd job-desc-wd)
|
||||
(env job-desc-env)
|
||||
(cmd job-desc-cmd))
|
||||
|
||||
(define-record-type :job-res
|
||||
(make-job-res errno stdout stderr)
|
||||
job-res?
|
||||
(errno job-res-errno)
|
||||
(stdout job-res-stdout)
|
||||
(stderr job-res-stderr))
|
||||
|
||||
(define (display-job-output j-res)
|
||||
(display
|
||||
(string-append
|
||||
"job finished with output exitno:\n"
|
||||
(number->string (job-res-errno j-res)) "\n"
|
||||
"job finished with output stdout:\n"
|
||||
(job-res-stdout j-res) "\n"
|
||||
"job finished with output stderr:\n"
|
||||
(job-res-stderr j-res) "\n"))
|
||||
(newline))
|
||||
|
||||
|
|
@ -0,0 +1,116 @@
|
|||
(define-record-type :jobd
|
||||
(really-make-jobd version-s job-c sig-mc)
|
||||
jobd?
|
||||
(version-s jobd-version-s)
|
||||
(job-c jobd-job-c)
|
||||
(sig-mc jobd-sig-mc))
|
||||
|
||||
(define-enumerated-type jobber-sig :jobber-sig
|
||||
jobber-sig?
|
||||
the-jobber-sigs
|
||||
jobber-sig-name
|
||||
jobber-sig-index
|
||||
(shutdown stop continue))
|
||||
|
||||
(define (cml-fork-collecting->rv id job-desc sig-ch)
|
||||
(let* ((ch (cml-sync-ch/make-channel))
|
||||
(cwd (job-desc-wd job-desc))
|
||||
(env (job-desc-env job-desc))
|
||||
(cmd (job-desc-cmd job-desc))
|
||||
(fds (list 1 2))
|
||||
(thunk (lambda () (with-total-env ,env (with-cwd cwd cmd))))
|
||||
(res-rv (cml-fork-collecting fds sig-ch thunk)))
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let ((results (cml-rv/sync res-rv)))
|
||||
(cml-sync-ch/send ch (make-job-res (list-ref results 0)
|
||||
(list-ref results 1)
|
||||
(list-ref results 2)))))
|
||||
(format #t "cml-fork-collecting->rv (no. ~a)\n" id))
|
||||
(cml-sync-ch/receive-rv ch)))
|
||||
|
||||
;;; ->alist?
|
||||
(define (jobber-sig->signal sig to-process-element)
|
||||
(cond
|
||||
((jobber-sig? sig)
|
||||
(cond
|
||||
((eq? (jobber-sig-name sig) 'shutdown)
|
||||
(cml-sync-ch/send to-process-element signal/kill))
|
||||
((eq? (jobber-sig-name sig) 'stop)
|
||||
(cml-sync-ch/send to-process-element signal/stop))
|
||||
((eq? (jobber-sig-name sig) 'continue)
|
||||
(cml-sync-ch/send to-process-element signal/cont))
|
||||
(else (error "jobber: jobber-sig->signal received unknown jobber-sig."))))
|
||||
(else (error "jobber: jobber-sig->signal received unknown object."))))
|
||||
|
||||
(define (job-desc->job-res id sig-mport j-des+res-ch)
|
||||
(let* ((j-des (car j-des+res-ch))
|
||||
(res-ch (cdr j-des+res-ch))
|
||||
(to-process-element (cml-sync-ch/make-channel))
|
||||
(sig-rcv-rv (cml-mcast-ch/mcast-port-receive-rv sig-mport))
|
||||
(job-res-rv (cml-fork-collecting->rv id j-des to-process-element)))
|
||||
(let finish-job ()
|
||||
(cml-rv/select
|
||||
(cml-rv/wrap sig-rcv-rv
|
||||
(lambda (sig)
|
||||
(jobber-sig->signal sig to-process-element)
|
||||
(finish-job)))
|
||||
(cml-rv/wrap job-res-rv
|
||||
(lambda (res)
|
||||
(cml-async-ch/send-async res-ch res)))))))
|
||||
|
||||
(define (jobber id job-ch sig-mport)
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ((new-job-rv (cml-async-ch/receive-async-rv job-ch))
|
||||
(sig-rcv-rv (cml-mcast-ch/mcast-port-receive-rv sig-mport)))
|
||||
(cml-rv/select
|
||||
(cml-rv/wrap new-job-rv
|
||||
(lambda (j-des+res-ch)
|
||||
(job-desc->job-res id sig-mport j-des+res-ch)))
|
||||
(cml-rv/wrap sig-rcv-rv
|
||||
(lambda (sig)
|
||||
(if (eq? (jobber-sig-name sig) 'shutdown)
|
||||
(terminate-current-thread)))))
|
||||
(loop))))
|
||||
(format #t "jobber (no. ~a)\n" id)))
|
||||
|
||||
(define jobd-vers "jobd-0.0.1")
|
||||
|
||||
(define (make-jobd)
|
||||
(let* ((version jobd-vers)
|
||||
(job-ch (cml-async-ch/make-async-channel))
|
||||
(sig-m-ch (cml-mcast-ch/make-mcast-channel))
|
||||
(start-jobber (lambda (id)
|
||||
(jobber id job-ch (cml-mcast-ch/mcast-port sig-m-ch)))))
|
||||
(for-each start-jobber (enumerate jobbers))
|
||||
(really-make-jobd version job-ch sig-m-ch)))
|
||||
|
||||
(define (version jobd)
|
||||
(jobd-version-s jobd))
|
||||
|
||||
(define (execute job-desc jobd)
|
||||
(let ((res-ch (cml-async-ch/make-async-channel)))
|
||||
(cml-async-ch/send-async (jobd-job-c jobd) (cons job-desc res-ch))
|
||||
(cml-async-ch/receive-async-rv res-ch)))
|
||||
|
||||
(define (shutdown jobd)
|
||||
(cml-mcast-ch/mcast (jobd-sig-mc jobd) (jobber-sig shutdown)))
|
||||
|
||||
(define (stop jobd)
|
||||
(cml-mcast-ch/mcast (jobd-sig-mc jobd) (jobber-sig stop)))
|
||||
|
||||
(define (continue jobd)
|
||||
(cml-mcast-ch/mcast (jobd-sig-mc jobd) (jobber-sig continue)))
|
||||
|
||||
(define (enumerate n-max)
|
||||
(cond
|
||||
((> n-max 1) (append (enumerate (- n-max 1)) (list n-max)))
|
||||
((= n-max 1) (list n-max))
|
||||
(else (error "n-max < 0"))))
|
||||
|
||||
(define jobbers 2)
|
||||
|
||||
(define (set-jobbers! n-of)
|
||||
(set! jobbers n-of))
|
||||
|
|
@ -1,38 +1,73 @@
|
|||
(define-record-type :rule
|
||||
(really-make-rule prereqs wants-build? build-func)
|
||||
(make-rule prereqs wants-build? build-func)
|
||||
is-rule?
|
||||
(prereqs rule-prereqs)
|
||||
(wants-build? rule-wants-build?)
|
||||
(build-func rule-build-func))
|
||||
|
||||
(define rules (list))
|
||||
(define lock-rules (make-lock))
|
||||
(define-record-type :rule-set
|
||||
(make-rule-set rules)
|
||||
is-rule-set?
|
||||
(rules rule-set-rules))
|
||||
|
||||
(define (rule-make rule init-state)
|
||||
(let* ((res-pres (map (lambda (prereq)
|
||||
(rule-make prereq init-state))
|
||||
(rule-prereqs rule)))
|
||||
(res-wants-build? (call-with-values
|
||||
(lambda ()
|
||||
(apply values (append res-pres
|
||||
(list init-state))))
|
||||
(rule-wants-build? rule)))
|
||||
(build? (car res-wants-build?))
|
||||
(cooked-state (cdr res-wants-build?)))
|
||||
(if build?
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(apply values (append (list build?)
|
||||
res-pres
|
||||
(list cooked-state))))
|
||||
(rule-build-func rule))
|
||||
res-wants-build?)))
|
||||
(define (make-empty-rule-set)
|
||||
(make-rule-set '()))
|
||||
|
||||
(define (make-rule prereqs wants-build? build-func)
|
||||
(let ((rule (really-make-rule prereqs wants-build? build-func)))
|
||||
(with-lock lock-rules
|
||||
(lambda ()
|
||||
(if (not (find (lambda (r) (eq? r rule)) rules))
|
||||
(set! rules (cons rule rules))
|
||||
(error "make-rule: rule already exists."))))
|
||||
rule))
|
||||
;;; listen-ch is a dummy here
|
||||
;;; now this and the one in make-rule.scm
|
||||
;;; are almost the same functions
|
||||
(define (rule-set-add rule rule-set)
|
||||
(let ((listen-ch #f))
|
||||
(if (not (assq rule rule-set))
|
||||
(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
|
||||
(error "make-rule: rule already exists."))))
|
||||
|
||||
(define-syntax rule-wants-build?*
|
||||
(syntax-rules ()
|
||||
((rule-wants-build?* ?rule ?init-state)
|
||||
((rule-wants-build? ?rule) ?init-state))
|
||||
((rule-wants-build?* ?rule '() ?init-state)
|
||||
((rule-wants-build? ?rule) ?init-state))
|
||||
((rule-wants-build?* ?rule (?p0-res ?p1-res ...) ?init-state)
|
||||
((rule-wants-build? ?rule) ?p0-res ?p1-res ... ?init-state))))
|
||||
|
||||
(define-syntax rule-build-func*
|
||||
(syntax-rules ()
|
||||
((rule-build-func* ?rule ?cooked-state)
|
||||
(((rule-build-func ?rule) ?cooked-state)))
|
||||
((rule-build-func* ?rule '() ?cooked-state)
|
||||
(((rule-build-func ?rule) ?cooked-state)))
|
||||
((rule-build-func* ?rule ?wants-build?-result (?p0 ?p1 ...) ?cooked-state)
|
||||
(((rule-build-func ?rule) ?wants-build?-result ?p0 ?p1 ... ?cooked-state)))))
|
||||
|
||||
;;;
|
||||
;;; RULE-RESULT
|
||||
;;;
|
||||
;;; (rule-result-wants-build? rule-result) --->
|
||||
;;; (wants-build?-result . cooked-state) oder (#f . cooked-state)
|
||||
;;;
|
||||
;;; (rule-result-build-func rule-result) --->
|
||||
;;; (build-func-result . end-state) oder #f
|
||||
;;;
|
||||
;;; (rule-make rule init-state rule-set) ---> rule-result
|
||||
;;;
|
||||
(define-record-type :rule-result
|
||||
(make-rule-result wants-build?-result build-func-result)
|
||||
is-rule-result?
|
||||
(wants-build?-result rule-result-wants-build?)
|
||||
(build-func-result rule-result-build-func))
|
||||
|
||||
(define (rule-make rule init-state rule-set)
|
||||
(let* ((pre-results (map (lambda (prereq)
|
||||
(if (assq prereq (rule-set-rules rule-set))
|
||||
(rule-make prereq init-state rule-set)
|
||||
(error "prerequisite is not in rule-set!")))
|
||||
(rule-prereqs rule)))
|
||||
(wants-build?-result (rule-wants-build?* rule pre-results init-state))
|
||||
(build-required? (car wants-build?-result))
|
||||
(cooked-state (cdr wants-build?-result)))
|
||||
(if build-required?
|
||||
(make-rule-result wants-build?-result
|
||||
(rule-build-func* rule build-required?
|
||||
pre-results cooked-state))
|
||||
(make-rule-result wants-build?-result #f))))
|
||||
|
|
|
|||
206
make-rule.scm
206
make-rule.scm
|
|
@ -1,16 +1,82 @@
|
|||
;;; TODO:
|
||||
;;; =====
|
||||
;;;
|
||||
;;; o Zyklenerkennung?
|
||||
;;; o nicht benoetigte Threads runterfahren
|
||||
|
||||
;;;
|
||||
;;; RULE
|
||||
;;;
|
||||
;;; (make-rule prereqs wants-build? build-func) ---> rule
|
||||
;;;
|
||||
;;; prereqs: '(#{:rule} ...)
|
||||
;;; wants-build?: (lambda (res-p0 res-p1 ... res-pN init-state) body ...)
|
||||
;;; res-pX: result of prerequisite-rule no. X
|
||||
;;; (wants-build? res-p0 ... res-pN init-state)
|
||||
;;; ---> (res-wants-build? . cooked-state)
|
||||
;;; build-func:
|
||||
;;; (lambda (res-wants-build? res-p0 ... res-pN cooked-state)
|
||||
;;; ---> (res-build-func . end-state)
|
||||
;;;
|
||||
(define-record-type :rule
|
||||
(really-make-rule prereqs wants-build? build-func)
|
||||
(make-rule prereqs wants-build? build-func)
|
||||
is-rule?
|
||||
(prereqs rule-prereqs)
|
||||
(wants-build? rule-wants-build?)
|
||||
(build-func rule-build-func))
|
||||
|
||||
;;;
|
||||
;;; RULE-SET
|
||||
;;;
|
||||
;;; (make-empty-rule-set) ---> rule-set
|
||||
;;; (rule-set-add! rule rule-set) ---> rule-set
|
||||
;;;
|
||||
(define-record-type :rule-set
|
||||
(make-rule-set rules)
|
||||
is-rule-set?
|
||||
(rules rule-set-rules))
|
||||
|
||||
(define (make-empty-rule-set)
|
||||
(make-rule-set '()))
|
||||
|
||||
(define (rule-set-add rule rule-set)
|
||||
(let ((listen-ch (collect&reply/make-channel)))
|
||||
(if (not (assq rule (rule-set-rules rule-set)))
|
||||
(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
|
||||
(error "make-rule: rule already exists."))))
|
||||
|
||||
(define (rule-set-get-listen-ch rule rule-set)
|
||||
(let ((?thing (assq rule (rule-set-rules rule-set))))
|
||||
(if (and ?thing (pair? ?thing) (is-collect&reply-channel? (cdr ?thing)))
|
||||
(cdr ?thing)
|
||||
(error "Rule not found in rule-set."))))
|
||||
|
||||
;;;
|
||||
;;; RULE-RESULT
|
||||
;;;
|
||||
;;; (rule-result-wants-build? rule-result) --->
|
||||
;;; (wants-build?-result . cooked-state) oder (#f . cooked-state)
|
||||
;;;
|
||||
;;; (rule-result-build-func rule-result) --->
|
||||
;;; (build-func-result . end-state) oder #f
|
||||
;;;
|
||||
;;; (rule-make rule init-state rule-set) ---> rule-result
|
||||
;;;
|
||||
(define-record-type :rule-result
|
||||
(make-rule-result wants-build?-result build-func-result)
|
||||
is-rule-result?
|
||||
(wants-build?-result rule-result-wants-build?)
|
||||
(build-func-result rule-result-build-func))
|
||||
|
||||
(define (rule-make rule init-state rule-set)
|
||||
;;
|
||||
;; this could be rewritten in future
|
||||
;;
|
||||
;; check for unused threads -> dont start them
|
||||
;;
|
||||
(map (lambda (r)
|
||||
(rule-node r (rule-set-get-listen-ch r rule-set) init-state rule-set))
|
||||
(map car (rule-set-rules rule-set)))
|
||||
(let* ((server (rule-set-get-listen-ch rule rule-set))
|
||||
(client (send&collect/make-channel))
|
||||
(recipient (make-link client server)))
|
||||
(send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
|
||||
(tagged-msg-stripped (send&collect/receive client))))
|
||||
|
||||
(define-enumerated-type rule-cmd :rule-cmd
|
||||
is-rule-cmd?
|
||||
the-rule-cmds
|
||||
|
|
@ -18,32 +84,6 @@
|
|||
rule-cmd-index
|
||||
(make link shutdown))
|
||||
|
||||
(define (rule-make rule init-state)
|
||||
(let* ((server (let ((found? (assq rule rules)))
|
||||
(if (is-collect&reply-channel? (cdr found?))
|
||||
(cdr found?)
|
||||
(error "rule-make: rule not found."))))
|
||||
(client (send&collect/make-channel))
|
||||
(recipient (make-link client server)))
|
||||
(send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
|
||||
(send&collect/send client (make-tagged-msg recipient init-state))
|
||||
(tagged-msg-stripped (send&collect/receive client))))
|
||||
|
||||
(define rules (list))
|
||||
(define lock-rules (make-lock))
|
||||
|
||||
(define (make-rule prereqs wants-build? build-func)
|
||||
(let ((rule (really-make-rule prereqs wants-build? build-func))
|
||||
(listen-ch (collect&reply/make-channel)))
|
||||
(with-lock lock-rules
|
||||
(lambda ()
|
||||
(if (not (assq rule rules))
|
||||
(begin
|
||||
(set! rules (alist-cons rule listen-ch rules))
|
||||
(rule-node rule listen-ch))
|
||||
(error "make-rule: rule already exists."))))
|
||||
rule))
|
||||
|
||||
(define (rule-node/sort-msgs unsorted to-order)
|
||||
(map (lambda (pos)
|
||||
(map (lambda (tmsg)
|
||||
|
|
@ -54,62 +94,72 @@
|
|||
unsorted))
|
||||
to-order))
|
||||
|
||||
(define (rule-node/make rule recipients connect-ch listen-ch init-state)
|
||||
(let* ((to-sort (map (lambda (recipient)
|
||||
(let ((tmsg-cmd (make-tagged-msg recipient
|
||||
(rule-cmd make)))
|
||||
(tmsg-state (make-tagged-msg recipient
|
||||
init-state)))
|
||||
(send&collect/send connect-ch tmsg-cmd)
|
||||
(send&collect/send connect-ch tmsg-state)
|
||||
(send&collect/receive connect-ch)))
|
||||
;;; send each prereq-thread a make command and the init-state
|
||||
;;; then wait for the results to return
|
||||
;;; sort to the order they were sent and ciao
|
||||
(define (rule-node/get-prereqs-results rule connect-ch recipients init-state)
|
||||
(rule-node/sort-msgs (map
|
||||
(lambda (recipient)
|
||||
(send&collect/send connect-ch
|
||||
(make-tagged-msg recipient
|
||||
(rule-cmd make)))
|
||||
(send&collect/receive connect-ch))
|
||||
recipients)
|
||||
recipients))
|
||||
(res-pres (rule-node/sort-msgs to-sort recipients))
|
||||
(res-build? (call-with-values
|
||||
(lambda ()
|
||||
(apply values (append res-pres
|
||||
(list init-state))))
|
||||
(rule-wants-build? rule)))
|
||||
(res-wants-build? (car res-build?))
|
||||
(cooked-state (cdr res-build?)))
|
||||
(if res-wants-build?
|
||||
(let ((build-res (call-with-values
|
||||
(lambda ()
|
||||
(apply values (append (list res-wants-build?)
|
||||
res-pres
|
||||
(list cooked-state))))
|
||||
(rule-build-func rule))))
|
||||
build-res)
|
||||
(cons #t cooked-state))))
|
||||
|
||||
(define (rule-node/recipients rule connect-ch)
|
||||
(let ((server-chs (map (lambda (r)
|
||||
(with-lock lock-rules
|
||||
(lambda ()
|
||||
(cdr (assq r rules)))))
|
||||
(define (rule-node/make rule listen-ch connect-ch recipients init-state)
|
||||
(let* ((prereqs-results (rule-node/get-prereqs-results rule connect-ch
|
||||
recipients init-state))
|
||||
(wants-build?-result (call-with-values
|
||||
(lambda ()
|
||||
(apply values (append prereqs-results
|
||||
(list init-state))))
|
||||
(rule-wants-build? rule)))
|
||||
(build-required? (car wants-build?-result))
|
||||
(cooked-state (cdr wants-build?-result)))
|
||||
(if build-required?
|
||||
(make-rule-result wants-build?-result
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(apply values (append (list build-required?)
|
||||
prereqs-results
|
||||
(list cooked-state))))
|
||||
(rule-build-func rule)))
|
||||
(make-rule-result wants-build?-result #f))))
|
||||
|
||||
(define (rule-node/make-links rule connect-ch rule-set)
|
||||
(let ((listen-chs (map (lambda (r)
|
||||
(cdr (assq r (rule-set-rules rule-set))))
|
||||
(rule-prereqs rule))))
|
||||
(map (lambda (server-ch)
|
||||
(make-link connect-ch server-ch))
|
||||
server-chs)))
|
||||
(map (lambda (listen-ch)
|
||||
(make-link connect-ch listen-ch))
|
||||
listen-chs)))
|
||||
|
||||
(define (rule-node rule listen-ch)
|
||||
(define (rule-node rule listen-ch init-state rule-set)
|
||||
(let ((connect-ch (send&collect/make-channel)))
|
||||
(spawn
|
||||
(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))
|
||||
(recipients #f))
|
||||
(?recipients #f))
|
||||
(let ((sender (tagged-msg-tag tmsg))
|
||||
(cmd (tagged-msg-stripped tmsg)))
|
||||
(cond
|
||||
((eq? (rule-cmd-name cmd) 'make)
|
||||
(if (not recipients)
|
||||
(set! recipients (rule-node/recipients rule connect-ch)))
|
||||
(let* ((tmsg (collect&reply/receive listen-ch))
|
||||
(init-state (tagged-msg-stripped tmsg))
|
||||
(res (rule-node/make rule recipients
|
||||
connect-ch listen-ch init-state)))
|
||||
(if (not ?recipients)
|
||||
(set! ?recipients
|
||||
(rule-node/make-links rule connect-ch rule-set)))
|
||||
(let ((res (rule-node/make rule listen-ch connect-ch
|
||||
?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) recipients)))
|
||||
((eq? (rule-cmd-name cmd) 'shutdown) (terminate-current-thread))))
|
||||
(node-loop (collect&reply/receive listen-ch) ?recipients)))
|
||||
'rule-node)))
|
||||
|
|
|
|||
31
makefile.scm
31
makefile.scm
|
|
@ -1,3 +1,25 @@
|
|||
;; (define d "~/.tmp")
|
||||
;;
|
||||
;; (makefile
|
||||
;; (makefile-rule (expand-file-name "skills.tex" d)
|
||||
;; '()
|
||||
;; (lambda ()
|
||||
;; (with-cwd d (display "Top: skills.tex"))))
|
||||
;; (makefile-rule (expand-file-name "skills.dvi" d)
|
||||
;; (expand-file-name "skills.tex" d)
|
||||
;; (lambda ()
|
||||
;; (with-cwd d
|
||||
;; (run (latex ,(expand-file-name "skills.tex" d))))))
|
||||
;; (makefile-rule (expand-file-name "skills.pdf" d)
|
||||
;; (expand-file-name "skills.dvi" d)
|
||||
;; (lambda ()
|
||||
;; (with-cwd d (run
|
||||
;; (dvipdfm -o
|
||||
;; ,(expand-file-name "skills.pdf" d)
|
||||
;; ,(expand-file-name "skills.dvi" d)))))))
|
||||
;;
|
||||
;; (make (expand-file-name "skills.pdf" d))
|
||||
|
||||
(makefile
|
||||
(makefile-rule "/home/johannes/.tmp/skills.tex"
|
||||
'()
|
||||
|
|
@ -8,13 +30,7 @@
|
|||
"/home/johannes/.tmp/skills.tex"
|
||||
(lambda ()
|
||||
(with-cwd "/home/johannes/.tmp"
|
||||
(begin
|
||||
(run (latex ,"/home/johannes/.tmp/skills.tex"))
|
||||
(run (dvicopy ,"/home/johannes/.tmp/skills.dvi"
|
||||
,"/home/johannes/.tmp/skills.dvicopy"))
|
||||
(rename-file "/home/johannes/.tmp/skills.dvicopy"
|
||||
"/home/johannes/.tmp/skills.dvi"
|
||||
#t)))))
|
||||
(run (latex ,"/home/johannes/.tmp/skills.tex")))))
|
||||
(makefile-rule "/home/johannes/.tmp/skills.pdf"
|
||||
"/home/johannes/.tmp/skills.dvi"
|
||||
(lambda ()
|
||||
|
|
@ -23,3 +39,4 @@
|
|||
,"/home/johannes/.tmp/skills.dvi"))))))
|
||||
|
||||
(make "/home/johannes/.tmp/skills.pdf")
|
||||
|
||||
|
|
|
|||
65
makros.scm
65
makros.scm
|
|
@ -1,44 +1,63 @@
|
|||
(define *fname->rule*-table '())
|
||||
(define rule-set (make-empty-rule-set))
|
||||
|
||||
;;; (*fname->rule*-get fname) ---> rule
|
||||
(define (*fname->rule*-get fname)
|
||||
(let ((rule-found? (assoc fname *fname->rule*-table)))
|
||||
(if rule-found?
|
||||
(cdr rule-found?))))
|
||||
(if rule-found? (cdr rule-found?))))
|
||||
|
||||
;;; (*fname->rule*-add! fname) ---> {}
|
||||
(define (*fname->rule*-add! fname rule)
|
||||
(let ((rule-found? (assq fname *fname->rule*-table)))
|
||||
(let ((rule-found? (assoc fname *fname->rule*-table)))
|
||||
(if rule-found?
|
||||
(error "There already exists a rule with this fname!")
|
||||
(set! *fname->rule*-table
|
||||
(alist-cons fname rule *fname->rule*-table)))))
|
||||
(begin
|
||||
(set! *fname->rule*-table
|
||||
(alist-cons fname rule *fname->rule*-table))
|
||||
(set! rule-set (rule-set-add rule rule-set))))))
|
||||
|
||||
(define-syntax make-is-out-of-date?
|
||||
(syntax-rules ()
|
||||
((make-is-out-of-date? ?target '())
|
||||
((make-is-out-of-date? ?target)
|
||||
(lambda ?args
|
||||
(cons (file-not-exists? ?target) ?args)))
|
||||
((make-is-out-of-date? ?target ?prereq0 ...)
|
||||
(lambda ?args
|
||||
(cons (or (file-not-exists? ?target)
|
||||
(> (file-last-mod ?prereq0)
|
||||
(> (file-last-mod ?prereq0)
|
||||
(file-last-mod ?target))
|
||||
...)
|
||||
(last ?args))))))
|
||||
|
||||
(define-syntax make-has-md5-digest=?
|
||||
(syntax-rules ()
|
||||
((make-has-md5-digest=? ?fingerprint ?target)
|
||||
(lambda ?args
|
||||
(cons (or (file-not-exists? ?target)
|
||||
(=? (md5-digest-for-port (open-input-file ?target))
|
||||
?fingerprint))
|
||||
?args)))
|
||||
((make-has-md5-digest=? ?fingerprint ?target ?prereq0 ...)
|
||||
(lambda ?args
|
||||
(cons (or (file-not-exists? ?target)
|
||||
(=? (md5-digest->number (md5-digest-for-port
|
||||
(open-input-file ?target)))
|
||||
(md5-digest->number ?fingerprint)))
|
||||
(last ?args))))))
|
||||
|
||||
(define-syntax makefile-rule
|
||||
(syntax-rules ()
|
||||
((makefile-rule '() ?prereqs ?action-thunk)
|
||||
(error "Target specification in makefile-rule matches '()!"))
|
||||
((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
|
||||
(begin
|
||||
(makefile-rule ?target0 ?prereqs ?action-thunk)
|
||||
...))
|
||||
((makefile-rule ?target '() ?action-thunk)
|
||||
(*fname->rule*-add! ?target
|
||||
(make-rule '()
|
||||
(make-is-out-of-date? ?target)
|
||||
(lambda ?args (?action-thunk)))))
|
||||
((makefile-rule ?target ?prereq0 ?action-thunk)
|
||||
(*fname->rule*-add! ?target
|
||||
(make-rule (list (*fname->rule*-get ?prereq0))
|
||||
(make-is-out-of-date? ?target ?prereq0)
|
||||
(lambda ?args (?action-thunk)))))
|
||||
((makefile-rule ?target (?prereq0 ...) ?action-thunk)
|
||||
(begin
|
||||
(*fname->rule*-add! ?target
|
||||
|
|
@ -46,19 +65,27 @@
|
|||
...)
|
||||
(make-is-out-of-date? ?target ?prereq0 ...)
|
||||
(lambda ?args (?action-thunk))))))
|
||||
((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
|
||||
(begin
|
||||
(makefile-rule ?target0 ?prereqs ?action-thunk)
|
||||
...))))
|
||||
((makefile-rule ?target ?prereq0 ?action-thunk)
|
||||
(*fname->rule*-add! ?target
|
||||
(make-rule (list (*fname->rule*-get ?prereq0))
|
||||
(make-is-out-of-date? ?target ?prereq0)
|
||||
(lambda ?args (?action-thunk)))))))
|
||||
|
||||
(define-syntax with-is-out-of-date?-check-func
|
||||
(syntax-rules ()
|
||||
((with-is-out-of-date?-producer ?make-is-out-of-date? ?makefile-rule
|
||||
|
||||
(define-syntax makefile
|
||||
(syntax-rules ()
|
||||
; ((makefile ()) '())
|
||||
((makefile ?rule0 ...)
|
||||
(list ?rule0 ...))))
|
||||
((makefile ?rule0 ...)
|
||||
(begin
|
||||
(set! rule-set (make-empty-rule-set))
|
||||
?rule0 ...))))
|
||||
|
||||
(define-syntax make
|
||||
(syntax-rules ()
|
||||
((make ?fname)
|
||||
(rule-make (*fname->rule*-get ?fname)
|
||||
"This is not an empty initial state."))))
|
||||
"This is not an empty initial state."
|
||||
rule-set))))
|
||||
|
|
|
|||
119
packages.scm
119
packages.scm
|
|
@ -1,3 +1,104 @@
|
|||
(define-interface jobd-interface
|
||||
(export make-jobd
|
||||
jobd?
|
||||
version
|
||||
execute
|
||||
stop
|
||||
continue
|
||||
shutdown
|
||||
set-jobbers!))
|
||||
|
||||
(define-structure jobd jobd-interface
|
||||
(open scheme-with-scsh
|
||||
formats
|
||||
srfi-1
|
||||
(with-prefix srfi-8 srfi-8/)
|
||||
srfi-9
|
||||
srfi-11
|
||||
threads
|
||||
threads-internal
|
||||
(with-prefix rendezvous cml-rv/)
|
||||
(with-prefix mcast-channels cml-mcast-ch/)
|
||||
(with-prefix rendezvous-channels cml-sync-ch/)
|
||||
(with-prefix rendezvous-async-channels cml-async-ch/)
|
||||
finite-types
|
||||
job
|
||||
cml-pe)
|
||||
(files jobd))
|
||||
|
||||
(define-interface cml-pe-interface
|
||||
(export cml-fork
|
||||
cml-fork-collecting))
|
||||
|
||||
(define-structure cml-pe cml-pe-interface
|
||||
(open scheme-with-scsh
|
||||
srfi-9
|
||||
threads
|
||||
(with-prefix rendezvous cml-rv/)
|
||||
(with-prefix rendezvous-channels cml-sync-ch/))
|
||||
(files cml-pe))
|
||||
|
||||
(define-interface mcast-channels-interface
|
||||
(export make-mcast-channel
|
||||
mcast-channel?
|
||||
mcast-port?
|
||||
mcast
|
||||
mcast-port
|
||||
mcast-port-receive
|
||||
mcast-port-receive-rv))
|
||||
|
||||
(define-structure mcast-channels mcast-channels-interface
|
||||
(open scheme
|
||||
srfi-9
|
||||
threads
|
||||
finite-types
|
||||
rendezvous
|
||||
rendezvous-channels)
|
||||
(files mcast-channels))
|
||||
|
||||
(define-interface job-interface
|
||||
(export make-job-desc
|
||||
job-desc?
|
||||
job-desc-wd
|
||||
job-desc-env
|
||||
job-desc-cmd
|
||||
make-job-res
|
||||
job-res?
|
||||
job-res-errno
|
||||
job-res-stdout
|
||||
job-res-stderr
|
||||
display-job-output))
|
||||
|
||||
(define-structure job job-interface
|
||||
(open scheme-with-scsh
|
||||
srfi-9)
|
||||
(files job))
|
||||
|
||||
(define-structure test-jobd
|
||||
(export do-some-jobs)
|
||||
(open scheme-with-scsh
|
||||
locks
|
||||
threads
|
||||
threads-internal
|
||||
srfi-1
|
||||
(with-prefix rendezvous cml-rv/)
|
||||
(with-prefix rendezvous-channels cml-sync-ch/)
|
||||
(with-prefix rendezvous-async-channels cml-async-ch/)
|
||||
cml-pe
|
||||
job
|
||||
(with-prefix jobd jobd/))
|
||||
(files test-jobd))
|
||||
|
||||
(define-structure test-mcast-channels
|
||||
(export test-it)
|
||||
(open scheme
|
||||
srfi-9
|
||||
threads
|
||||
rendezvous
|
||||
rendezvous-channels
|
||||
mcast-channels)
|
||||
(files test-mcast-channels))
|
||||
|
||||
(define-interface collect-channels-interface
|
||||
(export make-tagged-msg
|
||||
is-tagged-msg?
|
||||
|
|
@ -30,9 +131,11 @@
|
|||
(define-interface make-rule-interface
|
||||
(export make-rule
|
||||
is-rule?
|
||||
rule-prereqs
|
||||
rule-wants-build?
|
||||
rule-build-func
|
||||
make-empty-rule-set
|
||||
rule-set-add
|
||||
is-rule-set?
|
||||
make-rule-result
|
||||
is-rule-result?
|
||||
rule-make))
|
||||
|
||||
(define-structure make-rule make-rule-interface
|
||||
|
|
@ -51,9 +154,11 @@
|
|||
(define-interface make-rule-no-cml-interface
|
||||
(export make-rule
|
||||
is-rule?
|
||||
rule-prereqs
|
||||
rule-wants-build?
|
||||
rule-build-func
|
||||
make-empty-rule-set
|
||||
rule-set-add
|
||||
is-rule-set?
|
||||
make-rule-result
|
||||
is-rule-result?
|
||||
rule-make))
|
||||
|
||||
(define-structure make-rule-no-cml make-rule-no-cml-interface
|
||||
|
|
@ -73,5 +178,5 @@
|
|||
(define-structure makros makros-interface
|
||||
(open scheme-with-scsh
|
||||
srfi-1
|
||||
make-rule)
|
||||
make-rule-no-cml)
|
||||
(files makros))
|
||||
|
|
|
|||
Loading…
Reference in New Issue