diff --git a/cml-pe.scm b/cml-pe.scm new file mode 100644 index 0000000..f137a6a --- /dev/null +++ b/cml-pe.scm @@ -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))) diff --git a/job.scm b/job.scm new file mode 100644 index 0000000..3cd72f9 --- /dev/null +++ b/job.scm @@ -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)) + diff --git a/jobd.scm b/jobd.scm new file mode 100644 index 0000000..12b86bb --- /dev/null +++ b/jobd.scm @@ -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)) diff --git a/make-rule-no-cml.scm b/make-rule-no-cml.scm index 673aabe..e7d4b73 100644 --- a/make-rule-no-cml.scm +++ b/make-rule-no-cml.scm @@ -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)))) diff --git a/make-rule.scm b/make-rule.scm index 94bbfc1..d2a4521 100644 --- a/make-rule.scm +++ b/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))) diff --git a/makefile.scm b/makefile.scm index e08264e..f690a6c 100644 --- a/makefile.scm +++ b/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") + diff --git a/makros.scm b/makros.scm index 3a7742e..6fc769a 100644 --- a/makros.scm +++ b/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)))) diff --git a/packages.scm b/packages.scm index 8422ba5..dd38af0 100644 --- a/packages.scm +++ b/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))