Megatest

Check-in [acb5b0b2be]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Fixed merge related issues.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.70-defunct
Files: files | file ages | folders
SHA1: acb5b0b2be22dbeb32dce08e209af609e92f80b1
User & Date: mrwellan on 2020-10-03 22:25:08
Other Links: branch diff | manifest | tags
Context
2020-10-04
02:21
Attempt to merge all across. Closed-Leaf check-in: 5e97f11795 user: mrwellan tags: v1.70-defunct
2020-10-03
22:25
Fixed merge related issues. check-in: acb5b0b2be user: mrwellan tags: v1.70-defunct
21:25
Fixed (again?) the DEAD issue. Bad logic on re-calc of prereq needed. The (runs:testdat-prereqs-not-met testdat) is telling you that this needs recalc as it was previously not met. Thus can bypass if *was* met previously (although why would we reach here if it was met previously?). check-in: d336ea7394 user: matt tags: v1.70-defunct
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [33c7316880] to [9136bd0109].

︙
568
569
570
571
572
573
574
575

576
577
578
579
580
581
582

568
569
570
571
572
573
574

575
576
577
578
579
580
581
582








-
+








	    (for-each
	     (lambda (file)
	       (let* ((fullname (conc "logs/" file)))
		 (if (directory? fullname)
		     (debug:print-info 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.")
		     (handle-exceptions
		      exn
		      (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn)
		      (debug:print-info 0 *default-log-port* "failed to remove " fullname ", exn=" exn)
		      (delete-file* fullname)))))
	     files)
	    (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files."))))))
  
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;; Do NOT check if not on homehost!
;;
︙
1313
1314
1315
1316
1317
1318
1319

1320
1321



1322
1323
1324
1325







1326
1327
1328


1329
1330
1331


1332
1333
1334

1335
1336
1337
1338
1339
1340
1341

1313
1314
1315
1316
1317
1318
1319
1320


1321
1322
1323
1324
1325


1326
1327
1328
1329
1330
1331
1332
1333


1334
1335



1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348








+
-
-
+
+
+


-
-
+
+
+
+
+
+
+

-
-
+
+
-
-
-
+
+



+








      rtestpatt)
     (else 
      (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
      args-testpatt))))



;; 
(define (common:false-on-exception thunk #!key (message #f))
  (handle-exceptions exn
(define (common:false-on-exception thunk #!key (message #f)(tries 1))
  (handle-exceptions
      exn
                     (begin
                       (if message
                           (debug:print-info 0 *default-log-port* message))
                       #f) (thunk) ))
          (debug:print-info 0 *default-log-port* message " exn=" exn))
      (if (> tries 1)
	  (begin
	    (thread-sleep! 1)
	    (common:false-on-exception thunk message: message tries: (- tries 1)))
	  #f))
    (thunk)))

(define (common:file-exists? path-string #!key (silent #f))
  ;; this avoids stack dumps in the case where 
(define (common:file-exists? path-string #!key (silent #f)(tries 1))
  ;; this avoids stack dumps in the case where NFS is slow or flakey

  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (common:false-on-exception (lambda () (file-exists? path-string))
  (common:false-on-exception
   (lambda ()(file-exists? path-string))
                             message: (if (not silent)
                                          (conc "Unable to access path: " path-string)
                                          #f)
   tries: tries
                             ))

(define (common:directory-exists? path-string)
  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (common:false-on-exception (lambda () (directory-exists? path-string))
                             message: (conc "Unable to access path: " path-string)
                             ))
︙

Modified runs.scm from [7122b9f2e0] to [c2e599115c].

︙
60
61
62
63
64
65
66
67

68
69
70
71
72
73
74

60
61
62
63
64
65
66

67
68
69
70
71
72
73
74








-
+








  )

(defstruct runs:testdat
  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal
  itemmaps
  (prereqs-not-met '())
  (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
︙
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
879
880
881
882
883

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








+
+
+
-
+
+

-
-
-
+
+
+
+
-
-
-
-
-
-
-



-
+









-
-
+
+
+
+

-
-
+
+
-
-
-
-
-
-
-

-








;;    => 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)

;; cache the result of get-prereqs-not-met and don't call it if called in past 10 seconds
;; NOTE: This is assuming that testdat is highly specific to this test
;;
(define (runs:lazy-get-prereqs-not-met  testdat run-id waitons hed item-path #!key (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps)
(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)
      (let* ((res (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: mode itemmaps: itemmaps)))
	   (< (- (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 result
      (let* ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: mode 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=" mode " itemmaps=" itemmaps)
			  '())))))
	(runs:testdat-prereqs-not-met-set! testdat res)
	(runs:testdat-last-update-set! testdat (current-seconds))
	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 testdat)
(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 (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
	  #;(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)))))
	 ;; (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))
︙
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818



1819
1820
1821
1822
1823
1824
1825

1801
1802
1803
1804
1805
1806
1807



1808
1809
1810
1811
1812
1813
1814
1815
1816
1817








-
-
-
+
+
+








	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
	  (let ((can-run-more    #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
	    (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)))
						    run-id waitons item-path testmode test-record
						    can-run-more items runname tconfig reglen test-registry
						    test-records itemmaps testdat)))
		  (if loop-list
		      (apply loop loop-list)
                      (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
︙

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