Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1822,11 +1822,11 @@ new-best) (if (null? tal) #f (loop (car tal)(cdr tal) best-host))))))))) (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)) (let* ((loadavg (common:get-cpu-load remote-host)) - (numcpus (if (< 1 numcpus-in) ;; not possible + (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again (common:get-num-cpus remote-host) numcpus-in)) (maxload (if force-maxload maxload-in (max maxload-in 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME? Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -230,12 +230,24 @@ (let ((db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not file-exists) (begin - - (if (and (configf:lookup *configdat* "setup" "use-wal") + (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname)) + (begin + (print "DEBUG: Setting tmp_mode for " fname) + (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode")) + ) + ) + (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname))) + (begin + (print "DEBUG: Setting nfs_mode for " fname) + (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode")) + ) + ) + (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode"))) + (configf:lookup *configdat* "setup" "use-wal") (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp (sqlite3:execute db "PRAGMA journal_mode=WAL;") (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) (initproc db))) (if (not readyexists) @@ -266,51 +278,10 @@ (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) ))) - - - - -;; ;; This routine creates the db. It is only called if the db is not already opened -;; ;; -;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) -;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) -;; (dbexists (common:file-exists? dbfile)) -;; (db (db:lock-create-open dbfile (lambda (db) -;; (handle-exceptions -;; exn -;; (begin -;; ;; (release-dot-lock dbpath) -;; (if (> attemptnum 2) -;; (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) -;; (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) -;; (db:initialize-run-id-db db) -;; (sqlite3:execute -;; db -;; "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" -;; (* run-id 30000) ;; allow for up to 30k tests per run -;; run-id) -;; ;; do a dummy query to test that the table exists and the db is truly readable -;; (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) -;; )))) ;; add strings db to rundb, not in use yet -;; (olddb (if *megatest-db* -;; *megatest-db* -;; (let ((db (db:open-megatest-db))) -;; (set! *megatest-db* db) -;; db))) -;; (write-access (file-write-access? dbfile))) -;; (if (and dbexists (not write-access)) -;; (set! *db-write-access* #f)) ;; only unset so other db's also can use this control -;; (dbr:dbstruct-rundb-set! dbstruct (cons db dbfile)) -;; (dbr:dbstruct-inuse-set! dbstruct #t) -;; (dbr:dbstruct-olddb-set! dbstruct olddb) -;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's? -;; (db:sync-tables db:sync-tests-only *megatest-db* db) -;; db)) - ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; (define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) ADDED junk/cube.scm Index: junk/cube.scm ================================================================== --- /dev/null +++ junk/cube.scm @@ -0,0 +1,103 @@ +(use gl glut 3viewer typed-records matchable) + +(define red '#f32(1 0 0 1)) ;; +(define blue '#f32(0 0 1 1)) ;; +(define green '#f32(0 1 0 1)) ;; +(define yellow '#f32(1 1 0 1)) ;; +(define white '#f32(1 1 1 1)) ;; +(define orange '#f32(1 0.5 0 1)) ;; +(define black '#f32(0 0 0 1)) ;; + +(define colors + `((1 . ,red ) ;; red + (2 . ,blue ) ;; blue + (3 . ,green ) ;; green + (4 . ,yellow ) ;; yellow + (5 . ,white ) ;; white + (6 . ,orange ) ;; orange + (7 . ,black ) ;; black + )) + +;; retrive color +(define (rc c) + (alist-ref c colors)) + +(defstruct cspec + (x 0) + (y 0) + (z 0) + (n (rc 1)) ;; north + (s (rc 1)) ;; south + (e (rc 1)) ;; east + (w (rc 1)) ;; west + (t (rc 1)) ;; top + (b (rc 1))) ;; bottom + +(define a 0) + +(define (spin id) + (set! a (modulo (+ a 1) 360))) + +(define (colorize id col) + (gl:Materialfv + gl:FRONT_AND_BACK gl:AMBIENT_AND_DIFFUSE + (if (object-highlighted? id) + '#f32(1 1 0 1) + col))) + +(define (make-cuber cspec) + (lambda (id) + (gl:Translatef (cspec-x cspec)(cspec-y cspec)(cspec-z cspec)) + (draw-side id (cspec-w cspec)) ;; west side + (gl:Translatef 0 1 0) + (gl:Rotatef 90 1 0 0) + (draw-side id (cspec-e cspec)) ;; east side + (gl:Translatef 0 0 1) + (gl:Rotatef 90 0 1 0) + (draw-side id (cspec-n cspec)) ;; east side + (gl:Translatef 0 0 1) + (gl:Rotatef 90 0 1 0) + (draw-side id (cspec-s cspec)) ;; east side + (gl:Translatef 0 0 1) + (gl:Rotatef 90 0 1 0) + (draw-side id (cspec-t cspec)) ;; east side + (gl:Translatef 0 1 0) + (gl:Rotatef 90 1 0 0) + (draw-side id (cspec-b cspec)) ;; east side + )) + +(define (draw-side id color) + (colorize id color) ;; '#f32(1 0 0 1)) + (gl:Begin gl:POLYGON) + (gl:Vertex2f 0 0) + (gl:Vertex2f 0 1) + (gl:Vertex2f 1 1) + (gl:Vertex2f 1 0) + (gl:End) + ) + +(define data + (map (lambda (inl) + (map string->number (string-split inl))) + (with-input-from-file "data.txt" + read-lines))) + +(print "data: " data) + +(use trace) + +;; (add-object draw-cube animate: spin select: (lambda _ (print "oink!"))) +;; (add-object draw-polygon animate: spin select: (lambda _ (print "oink!"))) +(gl:Clear gl:COLOR_BUFFER_BIT) +(for-each + (lambda (dat) + ;; (let ((c1 (make-cspec e: red w: blue n: green s: yellow t: white b: orange))) + (match dat + ((x y z n s e w t b) + (let ((c1 (make-cspec x: x y: y z: z n: (rc n) s: (rc s) e: (rc e) w: (rc w) t: (rc t) b: (rc b)))) + (pp (cspec->alist c1)) + (add-object (make-cuber c1) select: (lambda _ (print "oink!"))))) + (else (print "bad object " dat)))) + data) +(gl:Flush) +(start-viewer) ADDED junk/data.txt Index: junk/data.txt ================================================================== --- /dev/null +++ junk/data.txt @@ -0,0 +1,27 @@ +0 0 0 1 2 3 4 5 6 +0 0 1 1 2 3 4 5 6 +0 0 2 1 2 3 4 5 6 +0 1 0 1 2 3 4 5 6 +0 1 1 1 2 3 4 5 6 +0 1 2 1 2 3 4 5 6 +0 2 0 1 2 3 4 5 6 +0 2 1 1 2 3 4 5 6 +0 2 2 1 2 3 4 5 6 +1 0 0 1 2 3 4 5 6 +1 0 1 1 2 3 4 5 6 +1 0 2 1 2 3 4 5 6 +1 1 0 1 2 3 4 5 6 +1 1 1 1 2 3 4 5 6 +1 1 2 1 2 3 4 5 6 +1 2 0 1 2 3 4 5 6 +1 2 1 1 2 3 4 5 6 +1 2 2 1 2 3 4 5 6 +2 0 0 1 2 3 4 5 6 +2 0 1 1 2 3 4 5 6 +2 0 2 1 2 3 4 5 6 +2 1 0 1 2 3 4 5 6 +2 1 1 1 2 3 4 5 6 +2 1 2 1 2 3 4 5 6 +2 2 0 1 2 3 4 5 6 +2 2 1 1 2 3 4 5 6 +2 2 2 1 2 3 4 5 6 Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -18,6 +18,6 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6528) +(define megatest-version 1.6529) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -255,17 +255,30 @@ ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment) ;; (mt:process-triggers run-id test-id newstate newstatus) #t))) + +(define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment) + (let* ((test-vec (rmt:get-testinfo-state-status run-id test-id)) + (state (vector-ref test-vec 3))) + (if (equal? state "COMPLETED") + #t + (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)))) + + (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) - (let ((test-id (rmt:get-test-id run-id test-name item-path))) - (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment) - ;; (mt:process-triggers run-id test-id new-state new-status) - #t)) + ;(let ((test-id (rmt:get-test-id run-id test-name item-path))) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment) + ;; (mt:process-triggers run-id test-id new-state new-status) + #t);) ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) +(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment) + (let ((test-id (rmt:get-test-id run-id test-name item-path))) + (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment))) + (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) (if tconf tconf (let ((test-dirs (tests:get-tests-search-path *configdat*))) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -1024,13 +1024,14 @@ ;; (area-allowed? area "area-needs-to-be-run" runkey contour #f)))) ;;(print "Area Allowed: " (area-allowed? area "area-needs-to-be-run" runkey contour #f)) ;Add code to check whether area is valid (if ;; This code checks whether the target has been passed in via argument, and only runs the specified target - (and (< packets-generated (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" )) 10000)) (if (args:get-arg "-target") - (if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f) - (area-allowed? area "area-needs-to-be-run" runkey contour #f))) + (and (< packets-generated (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" )) 10000)) + (if (args:get-arg "-target") + (if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f) + (area-allowed? area "area-needs-to-be-run" runkey contour #f))) (let* ((script (car cmd)) (params (cdr cmd)) (cmd (conc script " " contour " " area " " runkey " " std-runname " " action " " params)) (res (handle-exceptions @@ -1512,10 +1513,11 @@ ;; (if (not (member key *legal-params*)) ;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil ;; (hash-table-keys adjargs)) (let-values (((uuid pkt) (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss))) + (print "run log @ " (conc (current-directory) "/" uuid "-" *action* ".log")) (write-pkt pktsdir uuid pkt)))) ((dispatch import rungen process) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (toppath (configf:lookup mtconf "scratchdat" "toppath"))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -910,12 +910,12 @@ (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") ", removing it from to-do list") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (if (not (null? prereq-fails)) - (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") - (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) + (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") + (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) ;; (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed) ;; (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) ;; BB: this works, btu equivalent for itemwait mode does not work. (if (or (not (null? reg))(not (null? tal))) (begin (hash-table-set! test-registry hed 'CANNOTRUN) @@ -1146,21 +1146,21 @@ (thread-sleep! 1) (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (begin (let ((my-test-id (rmt:get-test-id run-id test-name item-path))) - (mt:test-set-state-status-by-id run-id my-test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites2")) + (mt:test-set-state-status-by-id-unless-completed run-id my-test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites2")) (if (or (not (null? reg))(not (null? tal))) (if (vector? hed) (begin (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") (let ((test-id (rmt:get-test-id run-id hed ""))) - (if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) + (if test-id (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) ;; This next is for the items (if (not (null? fails)) @@ -1196,11 +1196,11 @@ (list (car tal)(cdr tal) reg reruns)) (begin (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state >" nth-try "< will be overridden and we'll retry.")) ;; was: (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) - (mt:test-set-state-status-by-testname run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f) + (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f) (hash-table-set! test-registry hed 'removed) ;; was 0 (if (not (and (null? reg) (null? tal))) (runs:loop-values tal reg reglen regfull reruns) #f)))) (else Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -135,11 +135,11 @@ (subrun:unset-subrun-removed test-run-dir)) (let* ((log-prefix "run") (switches (subrun:selector+log-switches test-run-dir log-prefix)) (run-wait #t) - (cmd (conc "megatest -run "switches" " + (cmd (conc "megatest -rerun-clean "switches" " (if run-wait "-run-wait " "")))) cmd)) (define (subrun:sanitize-path inpath)