automatically wrap actor threads with exception stack trace dump

src/gerbil/prelude/core.ss

@@ -281,7 +281,7 @@ package: gerbil
     gerbil-home
 
     ;; concurrency primitives
-    spawn spawn/name spawn/group spawn-actor spawn-thread
+    spawn spawn/name spawn/group
     thread-local-ref thread-local-get thread-local-set! thread-local-clear!
     unhandled-actor-exception-hook-set!
 

src/gerbil/runtime/thread.ss

@@ -10,14 +10,17 @@ namespace: #f
 
 ;; spawn an actor thread apply f to args
 (def (spawn f . args)
-  (spawn-actor f args #!void #f))
+  (check-procedure f spawn)
+  (spawn-actor f args '#!void #f))
 
 ;; spawn a named actor thread
 (def (spawn/name name f . args)
+  (check-procedure f spawn/name)
   (spawn-actor f args name #f))
 
 ;; spawn a named actor thread with a new thread group
 (def (spawn/group name f . args)
+  (check-procedure f spawn/group)
   (let (tgroup (make-thread-group name))
     (spawn-actor f args name tgroup)))
 
@@ -46,12 +49,9 @@ namespace: #f
              exn))))
        thunk)))
 
-  (unless (procedure? f)
-    (raise (Error "bad argument; expected procedure" where: 'spawn irritants: (cons f args))))
-
-  (let ((thunk (if (null? args) f
-                   (lambda () (apply f args))))
-        (tgroup (or tgroup (current-thread-group))))
+  (let* ((thunk (if (null? args) f (cut apply f args)))
+         (thunk (cut with-exception-stack-trace thunk))
+         (tgroup (or tgroup (current-thread-group))))
     (thread-start!
      (thread-init!
       (construct-actor-thread #f 0)
@@ -144,6 +144,32 @@ namespace: #f
       proc
       (cut mutex-unlock! mx)))
 
+;; utilities for exception printing
+(def (with-exception-stack-trace thunk (error-port (current-error-port)))
+  (with-exception-handler
+   (let (E (current-exception-handler))
+     (lambda (exn)
+       (continuation-capture
+        (lambda (cont)
+          (dump-stack-trace! cont exn error-port)
+          (E exn)))))
+   thunk))
+
+(def (dump-stack-trace! cont exn (error-port (current-error-port)))
+  (let ((out (open-output-string)))
+    (fix-port-width! out)
+    (display "*** Unhandled exception in " out)
+    (display (current-thread) out)
+    (newline out)
+    (display-exception exn out)
+
+    ;; only do that if there no stack trace in the exception already
+    (unless (StackTrace? exn)
+      (display "Continuation backtrace: " out)
+      (newline out)
+      (display-continuation-backtrace cont out))
+    (##write-string (get-output-string out) error-port)))
+
 ;; actor thread type
 (extern
   actor-thread? construct-actor-thread

src/std/actor-v18/api.ss

@@ -128,7 +128,7 @@
       (ensemble-add-server! server-id public-addrs roles))
     ;; run it!
     (try
-     (with-exception-stack-trace thunk)
+     (thunk)
      (catch (e)
        (display "*** ERROR " (current-error-port))
        (display-exception e (current-error-port))))

src/std/actor-v18/connection.ss

@@ -32,9 +32,6 @@
       addr)))
 
 (def (actor-listener srv sock cookie)
-  (with-exception-stack-trace (cut actor-listener-main srv cookie sock)))
-
-(def (actor-listener-main srv cookie sock)
   (let/cc exit
     (while #t
       (try
@@ -57,9 +54,6 @@
               (warnf "error accepting connection: ~a [~a]" (strerror errno) errno)))))))))
 
 (def (actor-acceptor srv sock cookie)
-  (with-exception-stack-trace (cut actor-acceptor-main srv sock cookie)))
-
-(def (actor-acceptor-main srv sock cookie)
   (using (sock : StreamSocket)
     (if (is-TLS? sock)
       ;; no handshake needed; TLS authenticated
@@ -132,9 +126,6 @@
            (fail! (error-message exn))))))))
 
 (def (actor-connector srv peer-id addrs cookie tls-context)
-  (with-exception-stack-trace (cut actor-connector-main srv peer-id addrs cookie tls-context)))
-
-(def (actor-connector-main srv peer-id addrs cookie tls-context)
   ;; try UNIX addresses first, TLS addresses second
   (let* (((values unix-addrs other-addrs)
           (partition (lambda (a) (eq? (car a) unix:)) addrs))
@@ -241,9 +232,6 @@
      #f)))
 
 (def (actor-connection srv peer-id sock reader writer direction)
-  (with-exception-stack-trace (cut actor-connection-main srv peer-id sock reader writer direction)))
-
-(def (actor-connection-main srv peer-id sock reader writer direction)
   (using (sock :- StreamSocket)
     (with-error-close sock
       ;; first order of business: set KEEPALIVE for tcp
@@ -299,9 +287,6 @@
               (warnf "unexpected message: ~a" unexpected)))))))))
 
 (def (actor-connection-reader srv peer-id reader)
-  (with-exception-stack-trace (cut actor-connection-reader-main srv peer-id reader)))
-
-(def (actor-connection-reader-main srv peer-id reader)
   (let/cc exit
     (while #t
       (try
@@ -320,9 +305,6 @@
          (exit e))))))
 
 (def (actor-connection-writer srv peer-id writer)
-  (with-exception-stack-trace (cut actor-connection-writer-main srv peer-id writer)))
-
-(def (actor-connection-writer-main srv peer-id writer)
   (let/cc exit
     (while #t
       (<<

src/std/actor-v18/loader.ss

@@ -22,9 +22,6 @@
   (spawn/name 'loader loader srv path))
 
 (def (loader srv path)
-  (with-exception-stack-trace (cut loader-main srv path)))
-
-(def (loader-main srv path)
   (register-actor! 'loader srv)
   (debugf "starting loader...")
 

src/std/actor-v18/message-test.ss

@@ -31,15 +31,15 @@
       (reset-thread!)
       (def (reply)
         (<- (value (--> (cons 'reply value)))))
-      (def reply-thread (spawn (cut with-exception-stack-trace reply)))
+      (def reply-thread (spawn reply))
       (check (->> reply-thread 'hello) => '(reply . hello))
       (thread-join! reply-thread))
 
     (test-case "send+receive reply timeout"
       (reset-thread!)
       (def (reply)
         (thread-sleep! +inf.0))
-      (def reply-thread (spawn (cut with-exception-stack-trace reply)))
+      (def reply-thread (spawn reply))
       (check-exception (->> reply-thread 'hello timeout: 1) timeout-error?)
       (thread-terminate! reply-thread))
 
@@ -53,7 +53,7 @@
       (reset-thread!)
       (def (reply)
         (thread-sleep! +inf.0))
-      (def reply-thread (spawn (cut with-exception-stack-trace reply)))
+      (def reply-thread (spawn reply))
       (check (-> reply-thread 'hello) => 0)
       (check (<- (value value)
                  (else #f))

src/std/actor-v18/registry.ss

@@ -34,9 +34,6 @@
 
 ;;; Internals
 (def (ensemble-registry srv registry)
-  (with-exception-stack-trace (cut ensemble-registry-main srv registry)))
-
-(def (ensemble-registry-main srv registry)
   (register-actor! 'registry srv)
   (infof "starting registry ...")
 

src/std/actor-v18/server.ss

@@ -194,10 +194,6 @@
        (reverse socks)))))
 
 (def (actor-server id known-servers tls-context cookie admin auth socks)
-  (with-exception-stack-trace
-   (cut actor-server-main id known-servers tls-context cookie admin auth socks)))
-
-(def (actor-server-main id known-servers tls-context cookie admin auth socks)
   ;; next actor numeric id; 0 is self
   (def next-actor-id 1)
   ;; server address cache

src/std/actor-v18/test-util.ss

@@ -23,7 +23,7 @@
   ;; drain all existing (leftover) messages
   (while (thread-receive 0 #f)))
 
-(def (echo-actor-main srv main)
+(def (echo-actor srv main)
   (def ref
     (match (register-actor! 'echo srv)
       (ref ref)))
@@ -38,18 +38,12 @@
           (greeting
            (--> (cons 'hello greeting)))))))
 
-(def (echo-actor srv main)
-  (with-exception-stack-trace (cut echo-actor-main srv main)))
-
-(def (void-actor-main srv main)
+(def (void-actor srv main)
   (let (ref (register-actor! 'void srv))
     (-> main (cons 'ready ref)))
   ;; wait for the death signal
   (thread-receive))
 
-(def (void-actor srv main)
-  (with-exception-stack-trace (cut void-actor-main srv main)))
-
 (def (actor-error-with? what)
   (lambda (exn)
     (and (actor-error? exn)

src/std/db/postgresql-driver.ss

@@ -273,9 +273,6 @@
      (raise e))))
 
 (def (postgresql-driver sock reader writer)
-  (with-exception-stack-trace (cut postgresql-driver-main sock reader writer)))
-
-(def (postgresql-driver-main sock reader writer)
   (def query-limit 1000)
   (def query-output #f)
   (def query-token #f)

src/std/error.ss

@@ -2,6 +2,7 @@
 ;;; (C) vyzo
 ;;; Gerbil error objects
 (import :gerbil/runtime/error
+        :gerbil/runtime/thread
         (for-syntax :gerbil/expander))
 (export Exception Exception?
         RuntimeException RuntimeException?
@@ -154,32 +155,6 @@
 (defraise/context (raise-bug where message irritants ...)
   (BUG (string-append "BUG: " message) irritants: [irritants ...]))
 
-;; utilities for exception printing
-(def (with-exception-stack-trace thunk (error-port (current-error-port)))
-  (with-exception-handler
-   (let (E (current-exception-handler))
-     (lambda (exn)
-       (continuation-capture
-        (lambda (cont)
-          (dump-stack-trace! cont exn error-port)
-          (E exn)))))
-   thunk))
-
-(def (dump-stack-trace! cont exn (error-port (current-error-port)))
-  (let ((out (open-output-string)))
-    (fix-port-width! out)
-    (display "*** Unhandled exception in " out)
-    (display (current-thread) out)
-    (newline out)
-    (display-exception exn out)
-
-    ;; only do that if there no stack trace in the exception already
-    (unless (StackTrace? exn)
-      (display "Continuation backtrace: " out)
-      (newline out)
-      (display-continuation-backtrace cont out))
-    (##write-string (get-output-string out) error-port)))
-
 ;; runtime exceptions
 (defrules export-runtime-exceptions ()
   ((_ (symbol ...) ...)

src/std/misc/threads.ss

@@ -2,7 +2,8 @@
 ;;; (C) vyzo at hackzen.org
 ;;; miscellaneous thread utilities
 
-(import :gerbil/gambit
+(import :gerbil/runtime/thread
+        :gerbil/gambit
         :std/error
         :std/sugar)
 (export primordial-thread-group

src/std/misc/wg.ss

@@ -18,9 +18,6 @@
     wg))
 
 (def (worker wg)
-  (with-exception-stack-trace (cut worker-main wg)))
-
-(def (worker-main wg)
   (using (wg :- WG)
     (let (ch wg.workch)
       (let loop ()

src/std/net/httpd/server.ss

@@ -92,7 +92,7 @@
      (when (current-actor-server)
        (register-actor! 'httpd))
      (parameterize ((current-http-server (current-thread)))
-       (with-exception-stack-trace loop))
+       (loop))
      (catch (e)
        (errorf "unhandled exception: ~a" e)
        (raise e))

src/std/net/socks/server.ss

@@ -72,7 +72,7 @@
    (for-each monitor acceptors)
    (when (current-actor-server)
      (register-actor! 'httpd))
-   (with-exception-stack-trace loop)
+   (loop)
    (catch (e)
      (errorf "unhandled exception: ~a" e)
      (raise e))

src/std/net/ssl-test.ss

@@ -136,10 +136,7 @@ END
         (SSLSocket-close sock)))
 
     (test-case "self-signed certificate"
-      (let (srv
-            (spawn
-             (cut with-exception-stack-trace
-                  (cut test-server test-certificate test-private-key))))
+      (let (srv (spawn test-server test-certificate test-private-key))
         (thread-sleep! .1)
         (test-client (insecure-client-ssl-context))
         (check (thread-join! srv) => (void))))))