Re: thread resource leaks if thread terminates with uncaught exception

Shiro Kawai <[email protected]> writes:

> I'll come back regarding the resource leak.

I am still playing around there. I now have a reverse proxy using pmap
which still exposes a similar problem after some time but I am not sure
it is really a leak. It looks more like the GC sometimes isn't running
often enough => the finalizers aren't called. After some digging I am
not even sure why the GC tends to run often enough most of the time. Is
that just good luck? At first I thought it is the GC_gcollect() in
port.c - but it isn't called at all?

If I add something like:

(when (> (num-open-files) 550)
  (with-output-to-port (current-error-port)
    (lambda()
      (print "WARNING: explicit gc run because we are getting low on file descriptors")
      (flush)
      (gc))))

just before the pmap call, this seems to suffice and it doesn't happen
very often. Something like this is also suggested here:
https://www.hboehm.info/gc/finalization.html
"If scarce resources are managed with finalization, the allocation
routine for that resource (e.g. open for file handles) should force a
garbage collection (two if that doesn't suffice) if it finds itself
short of the resource."

#!/bin/sh
#| -*- mode: scheme; coding: utf-8; -*-
export GC_PRINT_STATS=1
export GC_PRINT_VERBOSE_STATS=1
exec gosh -I. -- $0 "$@"
|#
(use makiki)
(use text.html-lite)
(use rfc.http)
(use gauche.threads)
(use file.util)
(use gauche.sequence)
(use control.pmap)

(with-module control.pmap
  (define join-exc (make-parameter #f))
  
  (define (%make-joiner r)
    (^[thread :optional (timeout #f) (timeout-val #f)]
      (guard (e [(terminated-thread-exception? e) r]
		[else (join-exc e) r])
	     (thread-join! thread timeout timeout-val))))
  
  (define-syntax %with-wrapped-join
    (syntax-rules ()
      [(_ body ...)
       (parameterize ([join-exc #f])
	 (receive rs (begin body ...)
           (if (join-exc)
             (raise (join-exc))
             (apply values rs))))]))
  
  (define-method run-map ((mapper <fully-concurrent-mapper>) proc coll)
    (let ([unique (list #f)]
          [ts (map (^e (make-thread (^[] (proc e)))) coll)]
          [timeout (absolute-time (~ mapper'timeout))]
          [timeout-val (~ mapper'timeout-val)])
      (%start-threads ts)
      (%with-wrapped-join
       (let1 join! (%make-joiner #f)
	 (if timeout
           ($ map (^r (if (and (pair? r) (eq? (car r) unique))
			(begin (thread-terminate! (cdr r)) timeout-val)
			r))
	      $ map (^t (join! t timeout (cons unique t))) ts)
           (map join! ts)))))))

;; todo: linux specific
(define (num-open-files)
  (guard (e
	  [else
	   +nan.0])
	 (length (directory-list "/proc/self/fd" :children? #t))))

(define-http-handler (GET) "/" (^[req app]
				 (receive (status headers body)
				     (http-get "localhost:8081" "/")
				   (respond/ok req body))))

(define (http-get-body)
  (receive (status headers body)
      ;; todo: detect host name and use it to force a real
      ;; dns lookup to occur?
      (http-get "localhost:8081" "/slow")
    body))

(define-http-handler (GET)
  "/timeout"
  (lambda(req app)
    #;(when (> (num-open-files) 550)
      #?=(port-buffering (current-error-port))
      (with-output-to-port (current-error-port)
	(lambda()
	  (print "WARNING: explicit gc run because we are getting low on file descriptors")
	  (gc))))

    (let1 r (guard (e
		    [(uncaught-exception-condition? e)
		     #?=(uncaught-exception-condition-reason e)]
		    [else #?=e])
		   (pmap (lambda(i)
			   #;(when (= i 100) (error "i=100"))
			   (http-get-body))
			 (iota 400)
			 :mapper (make-fully-concurrent-mapper
				  0.1 'timeout)))
      (cond [(and (list? r) (eq? (car r) 'timeout))
	     (respond/ok req
			 (list
			  (html-doctype)
			  (html:html
			   (html:head (html:title "timeout"))
			   (html:body
			    (html:p "timeout")
			    (html:p
			     (string-append
			      (x->string (num-open-files))
			      " open files"))))))]
	    [(and (message-condition? r) (string=? (~ r 'message) "i=100"))
	     (respond/ok req "i=100\n")]
	    [else
	     (request-error :body r)]))))

(define (main args)
  #?=(sys-getpid)
  (debug-print-width 4000)
  (start-http-server :port 8080 :error-log #t)
  0)