Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

- Added concept of process naming. It greatly helps debugging. Calling

  the 'top' procedure in the console will show something like this:

> (top)
*** THREAD LIST:
#<thread #1 primordial>       RUNNING
#<thread #2 termite-dispatcher> WAITING #<condition-variable #3 #f>
#<thread #4 termite-linker>   WAITING #<condition-variable #5 #f>
#<thread #6 termite-spawner>  WAITING #<condition-variable #7 #f>
#<thread #8 termite-publisher> WAITING #<condition-variable #9 #f>
#<thread #10 termite-logger>  WAITING #<condition-variable #11 #f>
#<thread #12 termite-ping-server> WAITING #<condition-variable #13 #f>
#<thread #14 termite-publisher-dictionary> WAITING #<condition-variable #15 #f>
#<thread #16 termite-tcp-server> WAITING #<input-port #17 (tcp-server 3001)>


- Fixed and improved error logging a bit, should be more helpful now and 
  is up-to-date with Gambit's changed to the 'display' procedure.
  • Loading branch information...
commit 6a89ec63d637adf0e9802e2b0959f6931fda5d5a 1 parent a8dd564
@yome yome authored
View
80 data.scm
@@ -2,10 +2,20 @@
;; (it would be "better" if those were implemented functionally)
+(define (data-make-process-name type)
+ (string->symbol
+ (string-append
+ (symbol->string
+ (thread-name
+ (current-thread)))
+ "-"
+ (symbol->string type))))
+
;; ----------------------------------------------------------------------------
;; Cells
-(define (make-cell . content)
+(define (make-cell #!key (name (data-make-process-name 'cell))
+ #!rest content)
(spawn
(lambda ()
(let loop ((content (if (pair? content)
@@ -15,13 +25,14 @@
((from tag 'empty?)
(! from (list tag (eq? (void) content)))
(loop content))
-
+
((from tag 'ref)
(! from (list tag content))
(loop content))
-
+
(('set! content)
- (loop content)))))))
+ (loop content)))))
+ name: name))
(define (cell-ref cell)
@@ -42,41 +53,43 @@
;; ----------------------------------------------------------------------------
;; Dictionary
-(define (make-dict)
+(define (make-dict #!key (name (data-make-process-name 'dictionary)))
(spawn
(lambda ()
(let ((table (make-table test: equal?
init: #f)))
(let loop ()
(recv
- ((from tag ('dict?))
- (! from (list tag #t)))
+ ((from tag ('dict?))
+ (! from (list tag #t)))
- ((from tag ('dict-length))
- (! from (list tag (table-length table))))
+ ((from tag ('dict-length))
+ (! from (list tag (table-length table))))
+
+ ((from tag ('dict-ref key))
+ (! from (list tag (table-ref table key))))
- ((from tag ('dict-ref key))
- (! from (list tag (table-ref table key))))
+ (('dict-set! key)
+ (table-set! table key))
- (('dict-set! key)
- (table-set! table key))
+ (('dict-set! key value)
+ (table-set! table key value))
- (('dict-set! key value)
- (table-set! table key value))
+ ((from tag ('dict-search proc))
+ (! from (list tag (table-search proc table))))
- ((from tag ('dict-search proc))
- (! from (list tag (table-search proc table))))
+ (('dict-for-each proc)
+ (table-for-each proc table))
- (('dict-for-each proc)
- (table-for-each proc table))
+ ((from tag ('dict->list))
+ (! from (list tag (table->list table))))
- ((from tag ('dict->list))
- (! from (list tag (table->list table))))
+ ((msg
+ (warning (list ignored: msg)))))
- ((msg
- (warning (list ignored: msg)))))
+ (loop))))
- (loop))))))
+ name: name))
(define (dict? dict)
(!? dict (list 'dict?) 1 #f)) ;; we only give a second to reply to this
@@ -124,7 +137,7 @@
;; ----------------------------------------------------------------------------
;; Bag
-(define (make-bag)
+(define (make-bag #!key (name (data-make-process-name 'bag)))
(spawn
(lambda ()
(let ((table (make-table test: equal?
@@ -133,29 +146,30 @@
(recv
((from tag ('bag?))
(! from (list tag #t)))
-
+
((from tag ('bag-length))
(! from (list tag (table-length table))))
-
+
(('bag-add! elt)
(table-set! table elt #t))
-
+
(('bag-remove! elt)
(table-set! table elt))
-
+
((from tag ('bag-member? elt))
(table-ref table elt))
-
+
((from tag ('bag-search proc))
(! from (list tag (table-search (lambda (k v) (proc k)) table))))
-
+
(('bag-for-each proc)
(table-for-each (lambda (k v) (proc k)) table))
-
+
((from tag ('bag->list))
(! from (list tag (map car (table->list table))))))
- (loop))))))
+ (loop))))
+ name: name))
(define (bag? bag)
View
2  deftype.scm
@@ -78,7 +78,7 @@
(void))))
(define (,maker ,@fields)
- (,facade-maker (server:start ,plugin (list ,@fields))))
+ (,facade-maker (server:start ,plugin (list ,@fields) name: ',type)))
,@(map (lambda (getter)
`(define (,getter x)
View
16 otp/gen_event.scm
@@ -58,19 +58,23 @@
handlers)
(void)))))
-(define (internal-event-manager-start spawner handlers)
- (let ((em (spawn event-manager)))
+(define (internal-event-manager-start spawner handlers name)
+ (let ((em (spawn event-manager name: name)))
(for-each
(lambda (handler)
(event-manager:add-handler em handler))
handlers)
em))
-(define (event-manager:start . handlers)
- (internal-event-manager-start spawn handlers))
+(define (event-manager:start
+ #!key (name 'anonymous-event-manager)
+ #!rest handlers )
+ (internal-event-manager-start spawn handlers name))
-(define (event-manager:start-link . handlers)
- (internal-event-manager-start spawn-link handlers))
+(define (event-manager:start-link
+ #!key (name 'anonymous-linked-event-manager)
+ #!rest handlers )
+ (internal-event-manager-start spawn-link handlers name))
(define (event-manager:add-handler event-manager handler . args)
(! event-manager (list 'add-handler handler args)))
View
10 otp/gen_server.scm
@@ -39,15 +39,15 @@
(('stop reason)
((server-plugin-terminate plugin) reason state)))))
-(define (internal-server-start spawner plugin args)
- (let ((server (spawner (lambda () (make-server plugin)))))
+(define (internal-server-start spawner plugin args name)
+ (let ((server (spawner (lambda () (make-server plugin)) name: name)))
(!? server (list 'init args) *server-timeout*)
server))
-(define (server:start plugin args)
- (internal-server-start spawn plugin args))
+(define (server:start plugin args #!key (name 'anonymous-generic-server))
+ (internal-server-start spawn plugin args name))
-(define (server:start-link plugin args)
+(define (server:start-link plugin args #!key (name 'anonymous-linked-generic-server))
(internal-server-start spawn-link plugin args))
(define (server:call server term)
View
155 termite.scm
@@ -52,15 +52,15 @@
;; nodes
(define-type node
- id: 8992144e-4f3e-4ce4-9d01-077576f98bc5
- read-only:
- host
- port)
+ id: 8992144e-4f3e-4ce4-9d01-077576f98bc5
+ read-only:
+ host
+ port)
;; tags
(define-type tag
- id: efa4f5f8-c74c-465b-af93-720d44a08374
- (uuid init: #f))
+ id: efa4f5f8-c74c-465b-af93-720d44a08374
+ (uuid init: #f))
;; * Test whether 'obj' is a pid.
(define (pid? obj)
@@ -69,10 +69,10 @@
;; NOTE It might be better to integrate with Gambit's exception mechanism
(define-type termite-exception
- id: 6a3a285f-02c4-49ac-b00a-aa57b1ad02cf
- origin
- reason
- object)
+ id: 6a3a285f-02c4-49ac-b00a-aa57b1ad02cf
+ origin
+ reason
+ object)
;; ----------------------------------------------------------------------------
@@ -89,16 +89,10 @@
(lambda (e)
(termite-log
'error
- (call-with-output-string ""
- (lambda (port)
- (display "#|\n" port)
- (display-exception-in-context
- e
- k
- port)
- ;; todo: provide a safe wrapper in Gambit runtime?
- (##cmd-b k port 0)
- (display "|#\n" port)))))))
+ (list
+ (call-with-output-string ""
+ (lambda (port)
+ (display-exception-in-context e k port))))))))
(cond
;; Propagated Termite exception?
((termite-exception? e)
@@ -119,37 +113,38 @@
;; * Start a new process executing the code in 'thunk'.
-(define (spawn thunk #!key (links '()))
+(define (spawn thunk #!key (links '()) (name 'anonymous))
(let ((t (make-thread
(lambda ()
(with-exception-handler
base-exception-handler
thunk)
- (shutdown!)))))
+ (shutdown!))
+ name)))
(thread-specific-set! t links)
(thread-start! t)
t))
-(define (spawn-linked-to to thunk)
- (spawn thunk links: (list to)))
+(define (spawn-linked-to to thunk #!key (name 'anonymous-linked-to))
+ (spawn thunk links: (list to) name: name))
;; * Start a new process with a bidirectional link to the current
;; process.
-(define (spawn-link thunk)
- (let ((pid (spawn thunk links: (list (self)))))
+(define (spawn-link thunk #!key (name 'anonymous-linked))
+ (let ((pid (spawn thunk links: (list (self)) name: name)))
(outbound-link pid)
pid))
;; * Start a new process on remote node 'node', executing the code
;; in 'thunk'.
-(define (remote-spawn node thunk #!key (links '()))
+(define (remote-spawn node thunk #!key (links '()) (name 'anonymous-remote))
(if (equal? node (current-node))
- (spawn thunk links: links)
+ (spawn thunk links: links name: name)
(!? (remote-service 'spawner node)
- (list 'spawn thunk links))))
+ (list 'spawn thunk links name))))
;; * Start a new process on remote node 'node', with a bidirectional
@@ -382,15 +377,15 @@
;; Wraps 'pid's representing Gambit output ports.
(define-type termite-output-port
- id: b0c30401-474c-4e83-94b4-d516e00fe363
- unprintable:
- pid)
+ id: b0c30401-474c-4e83-94b4-d516e00fe363
+ unprintable:
+ pid)
;; Wraps 'pid's representing Gambit input ports.
(define-type termite-input-port
- id: ebb22fcb-ca61-4765-9896-49e6716471c3
- unprintable:
- pid)
+ id: ebb22fcb-ca61-4765-9896-49e6716471c3
+ unprintable:
+ pid)
;; Start a process representing a Gambit output port.
(define (spawn-output-port port #!optional (serialize? #f))
@@ -409,7 +404,8 @@
(where (procedure? proc))
(proc port))
(x (warning "unknown message sent to output port: " x)))
- (loop))))))
+ (loop)))
+ name: 'termite-output-port)))
;; Start a process representing a Gambit input port.
(define (spawn-input-port port #!optional (serialize? #f))
@@ -428,7 +424,8 @@
(where (procedure? proc))
(! from (list token (proc port))))
(x (warning "unknown message sent to input port: " x)))
- (loop))))))
+ (loop)))
+ name: 'termite-input-port)))
;; IO parameterization
;; (define current-termite-input-port (make-parameter #f))
@@ -571,20 +568,22 @@
(msg
(warning "serializing-output-port ignored message: " msg)))
- (loop)))))
+ (loop)))
+ name: 'termite-serializing-output-port))
(define (start-serializing-active-input-port port receiver)
(spawn-link
- (lambda ()
- (let loop ()
- (let ((data (deserialize port)))
- ;; to receive exceptions...
- (? 0 'ok)
- ;; (debug in: data)
- (if (eof-object? data) (shutdown!))
- (! receiver (list (self) data))
- (loop))))))
+ (lambda ()
+ (let loop ()
+ (let ((data (deserialize port)))
+ ;; to receive exceptions...
+ (? 0 'ok)
+ ;; (debug in: data)
+ (if (eof-object? data) (shutdown!))
+ (! receiver (list (self) data))
+ (loop))))
+ name: 'termite-serializing-active-input-port))
;; a tcp server listens on a certain port for new tcp connection
@@ -598,7 +597,8 @@
(lambda ()
(let loop ()
(on-connect (read tcp-server-port)) ;; io override
- (loop))))))
+ (loop)))
+ name: 'termite-tcp-server)))
;; MESSENGERs act as proxies for sockets to other nodes
@@ -625,7 +625,8 @@
(! out (list 'write (current-node)))
- (messenger-loop node in out))))))))
+ (messenger-loop node in out))))))
+ name: 'termite-outbound-messenger))
;; start a MESSENGER for an 'inbound' connection (another node
@@ -646,7 +647,8 @@
((,in node)
;; registering messenger to local dispatcher
(! dispatcher (list 'register (self) node))
- (messenger-loop node in out)))))))))
+ (messenger-loop node in out)))))))
+ name: 'termite-inbound-messenger))
(define (messenger-loop node in out)
@@ -711,7 +713,8 @@
(msg
(warning "dispatcher ignored message: " msg) ;; uh...
- (loop known-nodes)))))))
+ (loop known-nodes)))))
+ name: 'termite-dispatcher))
;; ----------------------------------------------------------------------------
@@ -734,7 +737,8 @@
(warning "in linker-loop: unknown object"))))
(msg
(warning "linker ignored message: " msg)))
- (loop)))))
+ (loop)))
+ name: 'termite-linker))
;; Remote spawning
@@ -744,12 +748,13 @@
(lambda ()
(let loop ()
(recv
- ((from tag ('spawn thunk links))
- (! from (list tag (spawn thunk links: links))))
+ ((from tag ('spawn thunk links name))
+ (! from (list tag (spawn thunk links: links name: name))))
(msg
(warning "spawner ignored message: " msg)))
- (loop)))))
+ (loop)))
+ name: 'termite-spawner))
;; the PUBLISHER is used to implement a mutable global env. for
@@ -773,7 +778,8 @@
(msg
(warning "puslisher ignored message: " msg)))
- (loop)))))
+ (loop)))
+ name: 'termite-publisher))
(define (publish-service name pid)
(! publisher (list 'publish name pid)))
@@ -834,13 +840,21 @@
;; might use similar style.)
(define (report-event event port)
- (display (list ";; --- " (formatted-current-time) " ---\n") port)
- (display (list "Event type: " (car event) "\n") port)
- (display (list "In process: " (cadr event) "\n") port)
- (display (list "On node: " (current-node) "\n") port)
- (write (caddr event) port)
- (newline port)
- (force-output port)
+ (match event
+ ((type who messages)
+ (with-output-to-port port
+ (lambda ()
+ (newline)
+ (display "[")
+ (display type)
+ (display "] ")
+ (display (formatted-current-time))
+ (newline)
+ (display who)
+ (newline)
+ (for-each (lambda (m) (display m) (newline)) messages)
+ (force-output))))
+ (_ (display "catch-all rule invoked in reporte-event")))
port)
(define file-output-log-handler
@@ -849,9 +863,9 @@
(lambda (args)
(match args
((filename)
- (open-output-file (list path: filename
- create: 'maybe
- append: #t)))))
+ (open-output-file (list path: filename
+ create: 'maybe
+ append: #t)))))
;; event
report-event
;; call
@@ -863,8 +877,8 @@
;; 'type' is a keyword (error warning info debug)
-(define (termite-log type message)
- (event-manager:notify logger (list type (self) message)))
+(define (termite-log type message-list)
+ (event-manager:notify logger (list type (self) message-list)))
(define (warning . terms)
(termite-log 'warning terms))
@@ -876,7 +890,7 @@
(termite-log 'debug terms))
(define logger
- (let ((logger (event-manager:start)))
+ (let ((logger (event-manager:start name: 'termite-logger)))
(event-manager:add-handler logger
(make-simple-event-handler
report-event
@@ -895,7 +909,8 @@
((from tag 'ping)
(! from (list tag 'pong)))
(msg (debug "ping-server ignored message" msg)))
- (loop)))))
+ (loop)))
+ name: 'termite-ping-server))
(define (ping node #!optional (timeout 1.0))
(!? (remote-service 'ping-server node) 'ping timeout 'no-reply))
Please sign in to comment.
Something went wrong with that request. Please try again.