Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -211,38 +211,38 @@ ;; keep this as a function to ease future (define (client:start run-id server-info) (http-transport:client-connect (tasks:hostinfo-get-interface server-info) (tasks:hostinfo-get-port server-info))) -;; client:signal-handler -(define (client:signal-handler signum) - (signal-mask! signum) - (set! *time-to-exit* #t) - (handle-exceptions - exn - (debug:print " ... exiting ...") - (let ((th1 (make-thread (lambda () - "") ;; do nothing for now (was flush out last call if applicable) - "eat response")) - (th2 (make-thread (lambda () - (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") - (thread-sleep! 1) ;; give the flush one second to do it's stuff - (debug:print 0 " Done.") - (exit 4)) - "exit on ^C timer"))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2)))) - -;; client:launch -;; Need to set the signal handler somewhere other than here as this -;; routine will go away. -;; -(define (client:launch run-id) - (set-signal-handler! signal/int client:signal-handler) - (set-signal-handler! signal/term client:signal-handler) - (if (client:setup run-id) - (debug:print-info 2 "connected as client") - (begin - (debug:print 0 "ERROR: Failed to connect as client") - (exit)))) - +;; ;; client:signal-handler +;; (define (client:signal-handler signum) +;; (signal-mask! signum) +;; (set! *time-to-exit* #t) +;; (handle-exceptions +;; exn +;; (debug:print " ... exiting ...") +;; (let ((th1 (make-thread (lambda () +;; "") ;; do nothing for now (was flush out last call if applicable) +;; "eat response")) +;; (th2 (make-thread (lambda () +;; (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") +;; (thread-sleep! 1) ;; give the flush one second to do it's stuff +;; (debug:print 0 " Done.") +;; (exit 4)) +;; "exit on ^C timer"))) +;; (thread-start! th2) +;; (thread-start! th1) +;; (thread-join! th2)))) +;; +;; ;; client:launch +;; ;; Need to set the signal handler somewhere other than here as this +;; ;; routine will go away. +;; ;; +;; (define (client:launch run-id) +;; (set-signal-handler! signal/int client:signal-handler) +;; (set-signal-handler! signal/term client:signal-handler) +;; (if (client:setup run-id) +;; (debug:print-info 2 "connected as client") +;; (begin +;; (debug:print 0 "ERROR: Failed to connect as client") +;; (exit)))) +;; Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -243,51 +243,60 @@ ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (std-exit-procedure) - (set! *time-to-exit* #t) - (debug:print-info 4 "starting exit process, finalizing databases.") - (if (debug:debug-mode 18) - (rmt:print-db-stats)) - (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds - (let ((run-ids (hash-table-keys *db-local-sync*))) - (if (and (not (null? run-ids)) - (configf:lookup *configdat* "setup" "megatest-db")) - (db:multi-db-sync run-ids 'new2old))) - (if *dbstruct-db* (db:close-all *dbstruct-db*)) - (if *inmemdb* (db:close-all *inmemdb*)) - (if (and *megatest-db* - (sqlite3:database? *megatest-db*)) - (begin - (sqlite3:interrupt! *megatest-db*) - (sqlite3:finalize! *megatest-db* #t) - (set! *megatest-db* #f))) - (if *task-db* (let ((db (cdr *task-db*))) - (if (sqlite3:database? db) - (begin - (sqlite3:interrupt! db) - (sqlite3:finalize! db #t) - (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread")) - (th2 (make-thread (lambda () - (debug:print 4 "Attempting clean exit. Please be patient and wait a few seconds...") - (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff - (debug:print 0 " Done.") - (exit)) - "clean exit"))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2))) + (let ((no-hurry (if *time-to-exit* ;; hurry up + #f + (begin + (set! *time-to-exit* #t) + #t)))) + (debug:print-info 4 "starting exit process, finalizing databases.") + (if (and no-hurry (debug:debug-mode 18)) + (rmt:print-db-stats)) + (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds + (let ((run-ids (hash-table-keys *db-local-sync*))) + (if (and (not (null? run-ids)) + (configf:lookup *configdat* "setup" "megatest-db")) + (if no-hurry (db:multi-db-sync run-ids 'new2old)))) + (if *dbstruct-db* (db:close-all *dbstruct-db*)) + (if *inmemdb* (db:close-all *inmemdb*)) + (if (and *megatest-db* + (sqlite3:database? *megatest-db*)) + (begin + (sqlite3:interrupt! *megatest-db*) + (sqlite3:finalize! *megatest-db* #t) + (set! *megatest-db* #f))) + (if *task-db* + (let ((db (cdr *task-db*))) + (if (sqlite3:database? db) + (begin + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread")) + (th2 (make-thread (lambda () + (debug:print 4 "Attempting clean exit. Please be patient and wait a few seconds...") + (if no-hurry + (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff + (thread-sleep! 1)) + (debug:print 0 " Done.") + (exit)) + "clean exit"))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2)))) (define (std-signal-handler signum) ;; (signal-mask! signum) + (set! *time-to-exit* #t) (debug:print 0 "ERROR: Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) +(set-signal-handler! signal/stop std-signal-handler) ;; ^Z ;;====================================================================== ;; Misc utils ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -224,26 +224,30 @@ (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting + (if (eq? signum signal/stop) + (debug:print 0 "ERROR: attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (let ((tdbdat (tasks:open-db))) (rmt:tasks-set-state-given-param-key task-key "killed")) (print "Killed by signal " signum ". Exiting") + (thread-sleep! 3) (exit)))) (th2 (make-thread (lambda () - (thread-sleep! 3) + (thread-sleep! 5) (debug:print 0 "Done") (exit 4))))) (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) - (set-signal-handler! signal/term sighand)) + (set-signal-handler! signal/term sighand) + (set-signal-handler! signal/stop sighand)) ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key task-key "running") (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process