Megatest

Check-in [447356ffac]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Getting closer to starting point without the bug
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | v1.65-pre-70
Files: files | file ages | folders
SHA1: 447356ffac0303c2a9f6d02552ddbb4a4dac8d3f
User & Date: mrwellan on 2020-10-04 01:59:09
Other Links: branch diff | manifest | tags
Context
2020-10-04
01:59
Getting closer to starting point without the bug Closed-Leaf check-in: 447356ffac user: mrwellan tags: v1.65-pre-70 (unpublished)
00:48
From: 53cfda8951 check-in: ba457efadd user: mrwellan tags: v1.65-pre-70 (unpublished)
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified db.scm from [5d8ca5b259] to [3a70da3249].

︙
1279
1280
1281
1282
1283
1284
1285
1286

1287
1288
1289
1290
1291
1292
1293
1294
1295

1296
1297
1298
1299
1300
1301
1302

1279
1280
1281
1282
1283
1284
1285

1286
1287
1288
1289
1290
1291
1292
1293
1294

1295
1296
1297
1298
1299
1300
1301
1302








-
+








-
+








		     (set! res (vector name)))
		   db 
		   "select name  from sqlite_master where type = 'trigger' ;" 
		   )))

(define (db:drop-triggers db)
  (for-each (lambda (key) 
              (sqlite3:execute db (conc "drop trigger " (car key))))
              (sqlite3:execute db (conc "drop trigger if exists " (car key))))
          db:trigger-list))

(define  (db:drop-trigger db tbl-name)
      (let* ((trigger-name (if (equal? tbl-name "test_steps")
				"update_teststeps_trigger" 
                                (conc "update_" tbl-name "_trigger"))))
       (for-each (lambda (key) 
             (if (equal? (car key) trigger-name)
             (sqlite3:execute db (conc "drop trigger " trigger-name))))
             (sqlite3:execute db (conc "drop trigger if exists " trigger-name))))
      db:trigger-list)))

(define  (db:create-trigger db tbl-name)
      (let* ((trigger-name (if (equal? tbl-name "test_steps")
                              "update_teststeps_trigger" 
                              (conc "update_" tbl-name "_trigger"))))
       (for-each (lambda (key)
︙

Modified runs.scm from [fad1b4b96b] to [3bf610c6dd].

︙
52
53
54
55
56
57
58
59





60
61
62
63
64
65
66

52
53
54
55
56
57
58

59
60
61
62
63
64
65
66
67
68
69
70








-
+
+
+
+
+








  (last-fuel-check         0)  ;; time when we last checked fuel
  (beginning-of-time       (current-seconds))
  )

(defstruct runs:testdat
  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal itemmaps prereqs-not-met)
  waitons testmode  newtal
  itemmaps
  (prereqs-not-met #f)
  (last-update 0) ;; 
  )
  
;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files
;;  - remove any that are over 3600 seconds old
;;  - if there are any that are younger than 10 seconds
;;      * sleep 10 seconds
;;      * touch my key-host-pid.softlock file
;;      * return
︙
830
831
832
833
834
835
836















837
838
839
840
841
842
843
844
845
846


847
848

849
850
851
852
853
854
855
856

857
858
859
860
861
862
863
864
865
866
867
868

869
870
871
872
873
874
875
876
877
878

834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864

865
866
867

868








869
870
871
872
873
874
875
876
877
878
879
880

881



882
883
884
885
886
887
888








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+









-
+
+

-
+
-
-
-
-
-
-
-
-
+











-
+
-
-
-








;;    => review of a previously seen test is higher priority of never visited test
;; reg - list of previously visited tests
;; tal - list of never visited tests
;;   prefer next hed to be from reg than tal.

(define runs:nothing-left-in-queue-count 0)

(define (runs:lazy-get-prereqs-not-met  testdat run-id waitons hed item-path
					#!key (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps)
  (if (and (runs:testdat-prereqs-not-met testdat)
	   (< (- (current-seconds) (runs:testdat-last-update testdat)) 10)) ;; only refresh for this test if it has been at least 10 seconds
      (runs:testdat-prereqs-not-met testdat) ;; return the cached value
      (let* ((res (rmt:get-prereqs-not-met run-id waitons hed item-path
					   mode: mode itemmaps: itemmaps)))
	(runs:testdat-prereqs-not-met-set! testdat res)
	(runs:testdat-last-update-set! testdat (current-seconds))
	(if (not (list? res))
	    (debug:print 0 *default-log-port*
			 "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
			 "  res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" mode " itemmaps=" itemmaps))
	(or res '()))))
	   
;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;;    (let loop ((hed         (car sorted-test-names))
;;	         (tal         (cdr sorted-test-names))
;;	         (reg         '()) ;; registered, put these at the head of tal 
;;	         (reruns      '()))
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record
			   can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
	 (prereqs-not-met (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
			    (if (list? res)
				res
				(begin
				  (debug:print 0 *default-log-port*
					       "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
					       "  res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps)
				  '()))))
         (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
	 (have-itemized   (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
	 ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails           (runs:calc-fails prereqs-not-met))
	 (prereq-fails    (runs:calc-prereq-fail prereqs-not-met))
	 (non-completed   (runs:calc-not-completed prereqs-not-met))
	 (runnables       (runs:calc-runnable prereqs-not-met))
         (unexpanded-prereqs
          (filter (lambda (testname)
                    (let* ((test-rec (hash-table-ref test-records testname))
                           (items       (tests:testqueue-get-items  test-rec)))
                      ;;(BB> "HEY " testname "=>"items)
                      (or (procedure? items)(eq? items 'have-procedure))))
                  waitons))
                  waitons)))


         )
    (debug:print-info 4 *default-log-port* "START OF INNER COND #2 "
		      "\n can-run-more:    " can-run-more
		      "\n testname:        " hed
		      "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
		      "\n non-completed:   " (runs:pretty-string non-completed) 
		      "\n prereq-fails:    " (runs:pretty-string prereq-fails)
		      "\n fails:           " (runs:pretty-string fails)
︙
1437
1438
1439
1440
1441
1442
1443
1444


1445
1446
1447
1448
1449
1450
1451

1447
1448
1449
1450
1451
1452
1453

1454
1455
1456
1457
1458
1459
1460
1461
1462








-
+
+








(define *max-tries-hash* (make-hash-table))

;;======================================================================
;; runs:run-tests-queue is called by runs:run-tests
;;======================================================================
;;
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry)
(define (runs:run-tests-queue run-id runname test-records keyvals flags
			      test-patts required-tests reglen-in all-tests-registry)
  ;; At this point the list of parent tests is expanded 
  ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags))

  ;; Do mark-and-find clean up of db before starting runing of quue
  ;;
  ;; (rmt:find-and-mark-incomplete)
︙
1662
1663
1664
1665
1666
1667
1668



1669
1670



1671
1672
1673
1674
1675
1676
1677

1673
1674
1675
1676
1677
1678
1679
1680
1681
1682


1683
1684
1685
1686
1687
1688
1689
1690
1691
1692








+
+
+
-
-
+
+
+








	 ;; 
	 ((not items)
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-2")
	  (debug:print-info 4 *default-log-port* "OUTER COND: (not items)")
	  (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
		   (not (null? tal)))
	      (loop (car tal)(cdr tal) reg reruns))
      ;; side effect is to save the prereqs in the struct
	  (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path
					 mode: testmode
	  (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
	  (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
					 itemmaps: itemmaps)
      ;; not sure why this used to be here
      ;; (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	  (let ((loop-list (runs:process-expanded-tests runsdat testdat)))
            (if loop-list (apply loop loop-list))))

	 ;; items processed into a list but not came in as a list been processed
	 ;;
	 ((and (list? items)     ;; thus we know our items are already calculated
	       (not   itemdat))  ;; and not yet expanded into the list of things to be done
︙
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737







1738
1739
1740

1741
1742
1743
1744
1745
1746
1747
1748
1749

1743
1744
1745
1746
1747
1748
1749



1750
1751
1752
1753
1754
1755
1756
1757
1758

1759


1760
1761
1762
1763
1764
1765
1766








-
-
-
+
+
+
+
+
+
+


-
+
-
-








         
	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
	  (let ((can-run-more    (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
	    (if (and (list? can-run-more)
		     (car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) ;; itemized test expanded here
	    (if (not can-run-more) #;(and (list? can-run-more) ;; IDEA, this mechanism may have had some value,
		                                               ;;; make it configurable to test pros/cons TODO
		(car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs
						    max-concurrent-jobs run-id waitons item-path
						    testmode test-record can-run-more items runname
						    tconfig reglen test-registry test-records itemmaps)))
		  (if loop-list
		      (apply loop loop-list)
                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)))
                      )
                  )
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))
         
	 ;; this case should not happen, added to help catch any bugs
	 ((and (list? items) itemdat)
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-5")
	  (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this")
︙

This page was generated in about 0.129s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00