Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -789,19 +789,19 @@ (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) - (if (common:low-noise-print 50 "disks not a dir " disk-num) + (if (common:low-noise-print 300 "disks not a dir " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) -1) ((not (file-write-access? dirpath)) - (if (common:low-noise-print 50 "disks not writeable " disk-num) + (if (common:low-noise-print 300 "disks not writeable " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) - (if (common:low-noise-print 50 "disks not a proper path " disk-num) + (if (common:low-noise-print 300 "disks not a proper path " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath))))) (if (> freespc bestsize) ADDED debugger.scm Index: debugger.scm ================================================================== --- /dev/null +++ debugger.scm @@ -0,0 +1,73 @@ +(use iup) + +(define *debugger-control* #f) +(define *debugger-rownum* 0) +(define *debugger-matrix* #f) +(define *debugger* #f) + +(define (debugger) + (if (not *debugger*) + (set! *debugger* + (thread-start! + (make-thread + (lambda () + (show + (dialog + (let ((pause #f) + (mtrx (matrix + #:expand "YES" + #:numlin 30 + #:numcol 3 + #:numlin-visible 20 + #:numcol-visible 2 + #:alignment1 "ALEFT" + ))) + (set! pause (button "Pause" + #:action (lambda (obj) + (set! *debugger-control* (not *debugger-control*)) + (attribute-set! pause "BGCOLOR" (if *debugger-control* + "200 0 0" + "0 0 200"))))) + (set! *debugger-matrix* mtrx) + (attribute-set! mtrx "WIDTH1" "300") + (vbox + mtrx + (hbox + pause))))) + (main-loop))))))) + +(define (debugger-start #!key (start 2)) + (set! *debugger-rownum* start)) + +(define (debugger-trace-var varname varval) + (let ((oldval (attribute *debugger-matrix* (conc *debugger-rownum* ":1"))) + (newval (conc varval))) + (if (not (equal? oldval newval)) + (begin + ;; (print "DEBUG: " varname " = " newval) + (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":0") varname) + (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":1") (conc varval)) + ;; (attribute-set! *debugger-matrix* "FITTOTEXT" "C1") + )) + (set! *debugger-rownum* (+ *debugger-rownum* 1)))) + + +(define (debugger-pauser) + (debugger) + (attribute-set! *debugger-matrix* "REDRAW" "ALL") + (let loop () + (if *debugger-control* + (begin + (print "PAUSED!") + (thread-sleep! 1) + (loop)) + ;;(thread-sleep! 0.01) + ))) + +;; ;; lets use the debugger eh? +;; (debugger-start) +;; (debugger-trace-var "can-run-more" can-run-more) +;; (debugger-trace-var "hed" hed) +;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) +;; (debugger-pauser) + Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -73,11 +73,11 @@ #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id (define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected ;; clean out old connections - (mutex-lock! *db-multi-sync-mutex*) + ;; (mutex-lock! *db-multi-sync-mutex*) (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin (for-each (lambda (run-id) (let ((connection (hash-table-ref/default *runremote* run-id #f))) (if (and (vector? connection) @@ -88,11 +88,11 @@ (case *transport-type* ((nmsg)(nn-close (http-transport:server-dat-get-socket (hash-table-ref *runremote* run-id))))) (hash-table-delete! *runremote* run-id))))) (hash-table-keys *runremote*))) - (mutex-unlock! *db-multi-sync-mutex*) + ;; (mutex-unlock! *db-multi-sync-mutex*) ;; (mutex-lock! *send-receive-mutex*) (let* ((run-id (if rid rid 0)) (connection-info (rmt:get-connection-info run-id))) ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) (if connection-info Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -27,10 +27,12 @@ (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") + +(include "debugger.scm") (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) @@ -159,10 +161,18 @@ (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) + ;; lets use the debugger eh? + (debugger-start start: 15) + (debugger-trace-var "runs:can-run-more-tests" "") + (debugger-trace-var "can-not-run-more" can-not-run-more) + (debugger-trace-var "num-running" num-running) + (debugger-trace-var "num-running-in-jobgroup" num-running-in-jobgroup) + (debugger-trace-var "job-group-limit" job-group-limit) + (debugger-pauser) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. @@ -520,10 +530,18 @@ "\n (member 'toplevel testmode): " (member 'toplevel testmode) "\n (null? non-completed): " (null? non-completed) "\n reruns: " reruns "\n items: " items "\n can-run-more: " can-run-more) + + ;; lets use the debugger eh? + (debugger-start start: 2) + (debugger-trace-var "runs:expand-items" "") + (debugger-trace-var "can-run-more" can-run-more) + (debugger-trace-var "hed" hed) + (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) + (debugger-pauser) (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch @@ -1064,10 +1082,21 @@ "\n reruns: " reruns "\n regfull: " regfull "\n reglen: " reglen "\n length reg: " (length reg) "\n reg: " reg) + + ;; lets use the debugger eh? + (debugger-start start: 7) + (debugger-trace-var "runs:run-tests-queue" "") + (debugger-trace-var "hed" hed) + (debugger-trace-var "tal" tal) + (debugger-trace-var "items" items) + (debugger-trace-var "item-path" item-path) + (debugger-trace-var "waitons" waitons) + (debugger-pauser) + ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member test-name waitons) (begin