syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Improve dataspace and skeleton logging

This commit is contained in:
Tony Garnock-Jones 2024-05-17 20:41:16 +02:00
parent 1f978aade4
commit a200c68715
2 changed files with 71 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
syndicate/dataspace.rkt
View File

@ -27,7 +27,7 @@
(require "schemas/dataspacePatterns.rkt")
(require "schemas/dataspacePatterns.meta.rkt")
(define-logger syndicate/dataspace)
(require (submod "skeleton.rkt" loggers))
(match (getenv "SYNDICATE_COLUMNS")
[#f (void)]
@ -54,13 +54,16 @@
(when (eq? (bag-change! assertions value +1) 'absent->present)
(match maybe-observe
[(? eof-object?)
(log-syndicate/dataspace-debug "Not an observer:~a" (pretty-assertion 4 value))
(log-syndicate/skeleton-debug "Not an observer:~a" (pretty-assertion 4 value))
(void)]
[(Observe pat ref)
(add-interest! this-turn skeleton pat ref)
(log-syndicate/dataspace-debug "Updated index:~a" (pretty-assertion 4 skeleton))
(log-syndicate/skeleton-debug "~v Updated index:\n~a" ds-e (dump-skeleton skeleton))
])
(add-assertion! this-turn skeleton value)))
(add-assertion! this-turn skeleton value)
(log-syndicate/skeleton-debug "~v After assertion of ~v:\n~a"
ds-e value (dump-skeleton skeleton))
))
#:retract (lambda (upstream-handle)
(match (hash-ref handles upstream-handle #f)
[#f (error 'dataspace "Peer retracted unknown handle ~v" upstream-handle)]
@ -71,11 +74,11 @@
(remove-assertion! this-turn skeleton value)
(match maybe-observe
[(? eof-object?)
(log-syndicate/dataspace-debug "Not an observer:~a" (pretty-assertion 4 value))
(log-syndicate/skeleton-debug "Not an observer:~a" (pretty-assertion 4 value))
(void)]
[(Observe pat ref)
(remove-interest! this-turn skeleton pat ref)
(log-syndicate/dataspace-debug "Updated index:~a" (pretty-assertion 4 skeleton))]))]))
(log-syndicate/skeleton-debug "~v Updated index:\n~a" ds-e (dump-skeleton skeleton))]))]))
#:message (lambda (message)
(log-syndicate/dataspace-debug "~v !~a" ds-e (pretty-assertion 4 message))
(send-assertion! this-turn skeleton message))))

69
syndicate/skeleton.rkt
View File

@ -10,12 +10,21 @@
remove-interest!
add-assertion!
remove-assertion!
send-assertion!)
send-assertion!
dump-skeleton)
(module+ for-test
(provide make-empty-skeleton/cache
extend-skeleton!))
(module loggers racket/base
(provide (all-defined-out))
(define-logger syndicate/skeleton)
(define-logger syndicate/dataspace))
(require (submod "." loggers))
(require racket/match)
(require racket/hash)
(require racket/list)
@ -132,7 +141,7 @@
(define peer-entry (make-hash))
(hash-set! (skeleton-accumulator-peers acc) ref peer-entry)
(for [(vars (in-bag (skeleton-accumulator-cache acc)))]
(hash-set! peer-entry vars (turn-assert! turn ref vars))))
(hash-set! peer-entry vars (turn-assert!/log turn ref vars))))
(define (skeleton-matched-constant-empty? sc)
(match-define (skeleton-matched-constant cache table) sc)
@ -150,7 +159,7 @@
(define acc (hash-ref (skeleton-matched-constant-table sc) vs #f))
(when acc
(for [(handle (in-hash-values (hash-ref (skeleton-accumulator-peers acc) ref)))]
(turn-retract! turn handle))
(turn-retract!/log turn handle))
(hash-remove! (skeleton-accumulator-peers acc) ref)
(when (hash-empty? (skeleton-accumulator-peers acc))
(hash-remove! (skeleton-matched-constant-table sc) vs)))
@ -272,7 +281,7 @@
['absent->present
(hash-for-each (skeleton-accumulator-peers skacc)
(lambda (ref peer-entry)
(hash-set! peer-entry vars (turn-assert! turn ref vars))))]
(hash-set! peer-entry vars (turn-assert!/log turn ref vars))))]
;; 'present->absent and 'absent->absent absurd
['present->present
(void)]))
@ -301,7 +310,7 @@
['present->absent
(hash-for-each (skeleton-accumulator-peers skacc)
(lambda (_ref peer-entry)
(turn-retract! turn (hash-ref peer-entry vars))
(turn-retract!/log turn (hash-ref peer-entry vars))
(hash-remove! peer-entry vars)))]
['present->present
(void)]
@ -309,7 +318,7 @@
['absent->present
;; 'absent->present should be absurd, but may be a programming error
(bag-change! cache vars 1) ;; undo the change
(log-warning "Removing assertion not previously added: ~v" _term)]))
(log-syndicate/skeleton-warning "Removing assertion not previously added: ~v" _term)]))
(define (remove-assertion! turn sk term)
(skeleton-modify! turn
@ -329,7 +338,21 @@
void
(lambda (turn skacc vars _term)
(hash-for-each (skeleton-accumulator-peers skacc)
(lambda (ref _peer-entry) (turn-message! turn ref vars))))))
(lambda (ref _peer-entry)
(turn-message!/log turn ref vars))))))
(define (turn-assert!/log turn ref a)
(define handle (turn-assert! turn ref a))
(log-syndicate/dataspace-debug " +++ ~a <--~a-- ~v" ref handle a)
handle)
(define (turn-retract!/log turn handle)
(log-syndicate/dataspace-debug " --- ~a" handle)
(turn-retract! turn handle))
(define (turn-message!/log turn ref a)
(log-syndicate/dataspace-debug " !!! ~a <---- ~v" ref a)
(turn-message! turn ref a))
;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj`
(define (apply-projection term proj)
@ -358,3 +381,35 @@
(hash-ref term key (void))]
[else
(error 'apply-projection "Term representation not supported: ~v" term)]))
(define (dump-skeleton sk)
(local-require racket/port)
(define (walk-node sk path)
(match-define (skeleton-node continuation edges) sk)
(printf " • ~v\n" path)
(walk-cont continuation)
(for [(entry edges)]
(match-define (cons (skeleton-move pop-count more-path) ctors) entry)
(for [((ctor next-sk) (in-hash ctors))]
(walk-node next-sk (append path (list pop-count more-path ctor))))))
(define (walk-cont skcont)
(match-define (skeleton-continuation cache table) skcont)
(for ((a (in-hash-keys cache))) (printf " → ~v\n" a))
(for (((cps cvs-table) (in-hash table)))
(match-define (constant-positions with-values required-to-exist) cps)
(printf " • =? ~v ∃ ~v\n" with-values required-to-exist)
(for (((cvs skconst) (in-hash cvs-table)))
(printf " = ~v\n" cvs)
(match-define (skeleton-matched-constant cache table) skconst)
(for ((a (in-hash-keys cache))) (printf " → ~v\n" a))
(for (((caps acc) (in-hash table)))
(printf " • ~v\n" caps)
(match-define (skeleton-accumulator cache peers) acc)
(for (((a n) (in-hash cache))) (printf " → ~v : ~a\n" a n))
(for (((peer asserted) (in-hash peers)))
(for (((cavs handle) (in-hash asserted)))
(printf " ~v « ~a:~v\n" peer handle cavs)))))))
(with-output-to-string
(lambda () (walk-node sk '()))))