Permalink
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...
1 parent a8dd564 commit 6a89ec63d637adf0e9802e2b0959f6931fda5d5a @yome yome committed May 21, 2009
Showing with 148 additions and 115 deletions.
  1. +47 −33 data.scm
  2. +1 −1 deftype.scm
  3. +10 −6 otp/gen_event.scm
  4. +5 −5 otp/gen_server.scm
  5. +85 −70 termite.scm
View
@@ -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
@@ -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
@@ -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
@@ -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)
Oops, something went wrong.

0 comments on commit 6a89ec6

Please sign in to comment.