From d42d574bf6924ae536731e73ace1dc6fa4a4aeff Mon Sep 17 00:00:00 2001 From: jottbee Date: Mon, 17 Jan 2005 16:56:59 +0000 Subject: [PATCH] make-rule and make-rule-no-cml work with new interface.\n\nmakros: ?prereqs can be expression --- make-rule-no-cml.scm | 80 ++++++++++------- make-rule.scm | 201 ++++++++++++++++++++++++++----------------- makefile.scm | 65 ++++++++------ makros.scm | 130 ++++++++++++++++++++-------- 4 files changed, 306 insertions(+), 170 deletions(-) diff --git a/make-rule-no-cml.scm b/make-rule-no-cml.scm index 673aabe..1488c25 100644 --- a/make-rule-no-cml.scm +++ b/make-rule-no-cml.scm @@ -1,38 +1,58 @@ (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-rules rule-set))) + (make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set))) + (error "make-rule: rule already exists.")))) + +;;; +;;; 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 (apply (rule-wants-build? rule) + (append pre-results (list init-state)))) + (build-required? (car wants-build?-result)) + (cooked-state (cdr wants-build?-result))) + (if build-required? + (make-rule-result wants-build?-result + (apply (rule-build-func rule) + (append (list build-required?) + pre-results + (list cooked-state)))) + (make-rule-result wants-build?-result #f)))) diff --git a/make-rule.scm b/make-rule.scm index 94bbfc1..67627c3 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,67 @@ 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 (apply (rule-wants-build? rule) + (append prereqs-results (list init-state)))) + (build-required? (car wants-build?-result)) + (cooked-state (cdr wants-build?-result))) + (if build-required? + (make-rule-result wants-build?-result + (apply (rule-build-func rule) + (append (list build-required?) + prereqs-results + (list cooked-state)))) + (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..7811515 100644 --- a/makefile.scm +++ b/makefile.scm @@ -1,25 +1,42 @@ -(makefile - (makefile-rule "/home/johannes/.tmp/skills.tex" - '() - (lambda () - (with-cwd "/home/johannes/.tmp" - (display "Top: /home/johannes/.tmp/skills.tex")))) - (makefile-rule "/home/johannes/.tmp/skills.dvi" - "/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))))) - (makefile-rule "/home/johannes/.tmp/skills.pdf" - "/home/johannes/.tmp/skills.dvi" - (lambda () - (with-cwd "/home/johannes/.tmp" - (run (dvipdfm -o ,"/home/johannes/.tmp/skills.pdf" - ,"/home/johannes/.tmp/skills.dvi")))))) +;;; (define d (expand-file-name "~/.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) "this is an empty init-state") + +(makefile + (makefile-rule "/home/bruegman/.tmp/skills.tex" + () + (lambda () + (with-cwd "/home/bruegman/.tmp" + (display "Top: /home/bruegman/.tmp/skills.tex")))) + (makefile-rule "/home/bruegman/.tmp/skills.dvi" + ("/home/bruegman/.tmp/skills.tex") + (lambda () + (with-cwd "/home/bruegman/.tmp" + (run (latex ,"/home/bruegman/.tmp/skills.tex"))))) + (makefile-rule "/home/bruegman/.tmp/skills.pdf" + ("/home/bruegman/.tmp/skills.dvi") + (lambda () + (with-cwd "/home/bruegman/.tmp" + (run (dvipdfm -o ,"/home/bruegman/.tmp/skills.pdf" + ,"/home/bruegman/.tmp/skills.dvi")))))) + +(make "/home/bruegman/.tmp/skills.pdf" "this is an empty init-state...") -(make "/home/johannes/.tmp/skills.pdf") diff --git a/makros.scm b/makros.scm index 3a7742e..337d15d 100644 --- a/makros.scm +++ b/makros.scm @@ -1,64 +1,118 @@ (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 + (syntax-rules () + ((make ?fname ?state) + (rule-make (*fname->rule*-get ?fname) + ?state + rule-set)))) + +(define-syntax makefile + (syntax-rules () + ((makefile ?rule0 ...) + (begin + (set! rule-set (make-empty-rule-set)) + ?rule0 ...)))) (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 ?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 - (make-rule (list (*fname->rule*-get ?prereq0) - ...) - (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 ...) ?thunk) + (makefile-rule-tmpvars () ?target (?prereq0 ...) ?thunk)))) -(define-syntax makefile - (syntax-rules () -; ((makefile ()) '()) - ((makefile ?rule0 ...) - (list ?rule0 ...)))) - -(define-syntax make +(define-syntax makefile-rule-tmpvars (syntax-rules () - ((make ?fname) - (rule-make (*fname->rule*-get ?fname) - "This is not an empty initial state.")))) + ((makefile-rule-tmpvars (tmp1 ...) ?target () ?thunk) + ;; + ;; ?target could be an expr: eval only once + ;; + (let ((target ?target)) + (*fname->rule*-add! target + (make-rule (list (*fname->rule*-get tmp1) + ...) + (make-is-out-of-date? target tmp1 ...) + (lambda ?args (?thunk)))))) + ;; + ;; recursively construct temporary, hygienic variables + ;; + ((makefile-rule-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk) + (let ((tmp2 ?prereq0)) + (makefile-rule-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk))))) + +(define-syntax makefile-rule-md5 + (syntax-rules () + ((makefile-rule-md5 ?fingerprint ?target (?prereq0 ...) ?thunk) + (makefile-rule-md5-tmpvars () ?fingerprint ?target (?prereq0 ...) ?thunk)))) + +(define-syntax makefile-rule-md5-tmpvars + (syntax-rules () + ((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target () ?thunk) + ;; + ;; ?target could be an expr: eval only once + ;; + (let ((target ?target)) + (*fname->rule*-add! target + (make-rule (list (*fname->rule*-get tmp1) + ...) + (make-has-md5-digest=? ?fingerprint + target + tmp1 ...) + (lambda ?args (?thunk)))))) + ;; + ;; recursively construct temporary, hygienic variables + ;; + ((makefile-rule-md5-tmpvars (tmp1 ...) + ?fingerprint + ?target + (?prereq0 ?prereq1 ...) + ?thunk) + (let ((tmp2 ?prereq0)) + (makefile-rule-md5-tmpvars (tmp1 ... tmp2) + ?fingerprint + ?target + (?prereq1 ...) + ?thunk)))))