Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -402,16 +402,25 @@ exn (begin (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") - (if (process:alive? pid) - (begin - (process-signal pid signal/int) - (thread-sleep! 5) - (if (process:process-alive? pid) - (process-signal pid signal/kill)))))) + (debug:print-info 0 "Signal mask=" (signal-mask)) + ;; (if (process:alive? pid) + ;; (begin + (map (lambda (pid-num) + (process-signal pid-num signal/term)) + (process:get-sub-pids pid)) + (thread-sleep! 5) + ;; (if (process:process-alive? pid) + (map (lambda (pid-num) + (handle-exceptions + exn + #f + (process-signal pid-num signal/kill))) + (process:get-sub-pids pid)))) + ;; (debug:print-info 0 "not killing process " pid " as it is not alive")))) pids) (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) (begin (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -11,10 +11,11 @@ ;;====================================================================== ;; Process convience utils ;;====================================================================== +(use regex) (declare (unit process)) (declare (uses common)) (define (conservative-read port) (let loop ((res "")) @@ -147,5 +148,17 @@ (file-exists? (conc "/proc/" pid)) (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) (and (number? rpid) (equal? rpid pid))))) +(define (process:get-sub-pids pid) + (with-input-from-pipe + (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid) + (lambda () + (let loop ((inl (read-line)) + (res '())) + (if (eof-object? inl) + (reverse res) + (let ((nums (map string->number + (string-split-fields "\\d+" inl)))) + (loop (read-line) + (append res nums))))))))