Megatest

Check-in [5cefaba81b]
Login
Overview
Comment:Fixed job killing on remote hosts
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | v1.12
Files: files | file ages | folders
SHA1: 5cefaba81b783e451170b0cc7556127d62aa0913
User & Date: mrwellan on 2011-06-16 00:17:01
Other Links: manifest | tags
Context
2011-06-16
10:15
Fixed annoying 'remove steps on re-run' bug check-in: 51810ab5ab user: mrwellan tags: trunk
00:17
Fixed job killing on remote hosts check-in: 5cefaba81b user: mrwellan tags: trunk, v1.12
2011-06-15
18:31
For max_concurrent_jobs if there are trailing spaces the string->number fails. Added quotes to make this occurance more obvious check-in: 194bedd45c user: mrwellan tags: trunk
Changes

Modified megatest.scm from [69c49cdbf1] to [38b46f671d].

371
372
373
374
375
376
377

378
379
380
381




382
383
384
385
386





387
388
389
390
391
392
393
394

395
396
397
398
399
400

401


























402













403
404

405









406

407
408
409
410
411

412
413
414
415
416
417
418
	    ;; on every access to reduce the probablitiy of 
	    ;; contention or stuck access on nfs.
	    (sqlite3:finalize! db)

	    (let* ((m            (make-mutex))
		   (kill-job?    #f)
		   (exit-info    (make-vector 3))

		   (runit        (lambda ()
				   (let-values
				    (((pid exit-status exit-code)
				      (run-n-wait fullrunscript)))




				    (mutex-lock! m)
				    (vector-set! exit-info 0 pid)
				    (vector-set! exit-info 1 exit-status)
				    (vector-set! exit-info 2 exit-code)
				    (mutex-unlock! m))))





		   (monitorjob   (lambda ()
				   (let* ((start-seconds (current-seconds))
					  (calc-minutes  (lambda ()
							   (inexact->exact 
							    (round 
							     (- 
							      (current-seconds) 
							      start-seconds))))))

				     (let loop ((minutes   (calc-minutes)))
				       (let ((db    (open-db)))
					 (set! kill-job? (test-get-kill-request db run-id test-name itemdat))
					 (test-update-meta-info db run-id test-name itemdat minutes)
					 (if kill-job? 
					     (begin 

					       (process-signal (vector-ref exit-info 0) signal/term)


























					       (sleep 2)













					       (handle-exceptions
						exn

						(print "ERROR: Problem killing process " (vector-ref exit-info 0))









						(process-signal (vector-ref exit-info 0) signal/kill))))

					 (sqlite3:finalize! db)
					 (thread-sleep! (+ 8 (random 4))) ;; add some jitter to the call home time to spread out the db accesses
					 (loop (calc-minutes)))))))
		   (th1          (make-thread monitorjob))
		   (th2          (make-thread runit)))

	      (thread-start! th1)
	      (thread-start! th2)
	      (thread-join! th2)
	      (mutex-lock! m)
	      (set! db (open-db))
	      (let* ((testinfo (db:get-test-info db run-id test-name (item-list->path itemdat))))
		(if (not (equal? (db:test-get-state testinfo) "COMPLETED"))







>

|
|
|
>
>
>
>
|
|
|
|
|
>
>
>
>
>







|
>





|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
|
>
>
>
>
>
>
>
>
>
|
>





>







371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
	    ;; on every access to reduce the probablitiy of 
	    ;; contention or stuck access on nfs.
	    (sqlite3:finalize! db)

	    (let* ((m            (make-mutex))
		   (kill-job?    #f)
		   (exit-info    (make-vector 3))
		   (job-thread   #f)
		   (runit        (lambda ()
				   ;; (let-values
				   ;;  (((pid exit-status exit-code)
				   ;;    (run-n-wait fullrunscript)))
				   (let ((pid (process-run fullrunscript)))
				     (let loop ((i 0))
				       (let-values
					(((pid-val exit-status exit-code) (process-wait pid #t)))
					(mutex-lock! m)
					(vector-set! exit-info 0 pid)
					(vector-set! exit-info 1 exit-status)
					(vector-set! exit-info 2 exit-code)
					(mutex-unlock! m)
					(if (eq? pid-val 0)
					    (begin
					      (thread-sleep! 2)
					      (loop (+ i 1)))
					    ))))))
		   (monitorjob   (lambda ()
				   (let* ((start-seconds (current-seconds))
					  (calc-minutes  (lambda ()
							   (inexact->exact 
							    (round 
							     (- 
							      (current-seconds) 
							      start-seconds)))))
					  (kill-tries 0))
				     (let loop ((minutes   (calc-minutes)))
				       (let ((db    (open-db)))
					 (set! kill-job? (test-get-kill-request db run-id test-name itemdat))
					 (test-update-meta-info db run-id test-name itemdat minutes)
					 (if kill-job? 
					     (begin
					       (mutex-lock! m)
					       (let* ((pid (vector-ref exit-info 0)))
						 (if (number? pid)
						     (begin
						       (print "WARNING: Request received to kill job (attempt # " kill-tries ")")
						       ;;(cond
						       ;;((>   kill-tries 0) ; 2)
						       (let ((processes (cmd-run->list (conc "pgrep -l -P " pid))))
							 (for-each 
							  (lambda (p)
							    (let* ((parts  (string-split p))
								   (p-id   (if (> (length parts) 0)
									       (string->number (car parts))
									       #f)))
							      (if p-id
								  (begin
								    (print "Killing " (cadr parts) "; kill -9  " p-id)
								    (system (conc "kill -9 " p-id))))))
							  (car processes))
							 (system (conc "kill -9 " pid))))
						     ;;(let* ((ppid (process-group-id pid))
						     ;;       (kcmd (conc "pkill -9 -g " ppid)))
						     ;;  ;; (process-signal pid signal/term)
						     ;;  ;; (process-signal pid signal/kill)
						     ;;  (print "Attempting to kill pid " pid " and children in process group " ppid " with command:\n    " kcmd)
						     ;;  (print "Children:")
						     ;;  (system (conc "pgrep -g -l " ppid))
						     ;;  (system kcmd)
						     ;;  (sleep 1) ;; give it a rest
						     ;;  (test-set-status! db run-id test-name "KILLED"  "FAIL"
						     ;;       	     itemdat (args:get-arg "-m"))
						     ;;  (sqlite3:finalize! db)
						     ;;  (exit 1)))))
						     (begin
						       (print "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
						       (test-set-status! db run-id test-name "KILLED"  "FAIL"
									 itemdat (args:get-arg "-m"))
						       (sqlite3:finalize! db)
						       (exit 1))))
					       ;;     (thread-terminate! job-thread)))
					       (set! kill-tries (+ 1 kill-tries))
					       (mutex-unlock! m)))
					 ;; (handle-exceptions
					       ;;  exn
					       ;;  (begin
					       ;;    (print "ERROR: Problem killing process " (vector-ref exit-info 0))
					       ;;    (abort exn))
					       ;;  (let* ((pid   (vector-ref exit-info 0))
					       ;;         ;; (pgid  (process-group-id pid))
					       ;;         ;; (cmd  (conc "pkill -9 -P " pgid))
					       ;;         )
					       ;;    ;; (print "Running \"" cmd "\"")
					       ;;    ;; (system cmd)
					       ;;    (print "Running \"kill -9 " pid "\"")
					       ;;    (system (conc "kill -9 " pid))
					       ;;    ;; (process-signal (vector-ref exit-info 0) signal/kill)
					       ;;    ))))
					 (sqlite3:finalize! db)
					 (thread-sleep! (+ 8 (random 4))) ;; add some jitter to the call home time to spread out the db accesses
					 (loop (calc-minutes)))))))
		   (th1          (make-thread monitorjob))
		   (th2          (make-thread runit)))
	      (set! job-thread th2)
	      (thread-start! th1)
	      (thread-start! th2)
	      (thread-join! th2)
	      (mutex-lock! m)
	      (set! db (open-db))
	      (let* ((testinfo (db:get-test-info db run-id test-name (item-list->path itemdat))))
		(if (not (equal? (db:test-get-state testinfo) "COMPLETED"))