Megatest

Check-in [cd59ba0d0b]
Login
Overview
Comment:found locus of debug_chained_waiton issue
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | debug_chained_waiton | v1.60_defunct
Files: files | file ages | folders
SHA1: cd59ba0d0bb52a5fc4d0388c655ab79cefffbb3d
User & Date: bjbarcla on 2016-04-12 18:26:32
Other Links: branch diff | manifest | tags
Context
2016-04-18
15:30
adding dfs poc for solving chained-waiton check-in: 985f2017bf user: bjbarcla tags: debug_chained_waiton, v1.60_defunct
2016-04-12
18:26
found locus of debug_chained_waiton issue check-in: cd59ba0d0b user: bjbarcla tags: debug_chained_waiton, v1.60_defunct
2016-04-06
15:50
Resurrected get and set vars from the meta table check-in: f01b76ecf0 user: mrwellan tags: v1.6031, v1.60_defunct
Changes

Modified runs.scm from [62ed47157d] to [27e776fe92].

255
256
257
258
259
260
261

262
263
264
265

266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284

285
286
287
288
289
290
291
    ;; override the number of reruns from the configs
    (if (and config-reruns
	     (> run-count config-reruns))
	(set! run-count config-reruns))
    
    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))


    (let ((sighand (lambda (signum)
		     ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
		     (if (eq? signum signal/stop)
			 (debug:print 0 "ERROR: attempt to STOP process. Exiting."))

		     (set! *time-to-exit* #t)
		     (print "Received signal " signum ", cleaning up before exit. Please wait...")
		     (let ((th1 (make-thread (lambda ()
					       (let ((tdbdat (tasks:open-db)))
						 (rmt:tasks-set-state-given-param-key task-key "killed"))
					       (print "Killed by signal " signum ". Exiting")
					       (thread-sleep! 3)
					       (exit))))
			   (th2 (make-thread (lambda ()
					       (thread-sleep! 5)
					       (debug:print 0 "Done")
					       (exit 4)))))
		       (thread-start! th2)
		       (thread-start! th1)
		       (thread-join! th2)))))
      (set-signal-handler! signal/int sighand)
      (set-signal-handler! signal/term sighand)
      (set-signal-handler! signal/stop sighand))


    (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (set! runconf (if (file-exists? runconfigf)
		      (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
		      (begin
			(debug:print 0 "WARNING: You do not have a run config file: " runconfigf)
			#f)))








>



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


|
|
>







255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
    ;; override the number of reruns from the configs
    (if (and config-reruns
	     (> run-count config-reruns))
	(set! run-count config-reruns))
    
    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))

    ;; if signal received, clean up and exit
    (let ((sighand (lambda (signum)
		     ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
		     (if (eq? signum signal/stop)
			 (debug:print 0 "ERROR: attempt to STOP process.")
                         (begin
                           (set! *time-to-exit* #t)
                           (print "Received signal " signum ", cleaning up before exit. Please wait...")
                           (let ((th1 (make-thread (lambda ()
                                                     (let ((tdbdat (tasks:open-db)))
                                                       (rmt:tasks-set-state-given-param-key task-key "killed"))
                                                     (print "Killed by signal " signum ". Exiting")
                                                     (thread-sleep! 3)
                                                     (exit))))
                                 (th2 (make-thread (lambda ()
                                                     (thread-sleep! 5)
                                                     (debug:print 0 "Done")
                                                     (exit 4)))))
                             (thread-start! th2)
                             (thread-start! th1)
                             (thread-join! th2)))))))
      (set-signal-handler! signal/int sighand)
      (set-signal-handler! signal/term sighand)
      ;;(set-signal-handler! signal/stop sighand)
      )
    
    (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (set! runconf (if (file-exists? runconfigf)
		      (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
		      (begin
			(debug:print 0 "WARNING: You do not have a run config file: " runconfigf)
			#f)))

318
319
320
321
322
323
324


325
326
327
328
329
330
331

    ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts)))
    (debug:print-info 0 "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " "))
    (debug:print-info 0 "all tests:         " (string-intersperse (sort all-test-names string<) " "))
    (debug:print-info 0 "test names:        " (string-intersperse (sort test-names string<) " "))
    (debug:print-info 0 "required tests:    " (string-intersperse (sort required-tests string<) " "))



    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
	(begin
	  ;; Is this still necessary? I think not. Unreachable tests are marked as such and 
	  ;; should not cause problems here.
	  ;;







>
>







321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336

    ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts)))
    (debug:print-info 0 "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " "))
    (debug:print-info 0 "all tests:         " (string-intersperse (sort all-test-names string<) " "))
    (debug:print-info 0 "test names:        " (string-intersperse (sort test-names string<) " "))
    (debug:print-info 0 "required tests:    " (string-intersperse (sort required-tests string<) " "))


    ;; allow-auto-rerun - undocumented, maybe unimplemented.
    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
	(begin
	  ;; Is this still necessary? I think not. Unreachable tests are marked as such and 
	  ;; should not cause problems here.
	  ;;
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
						   (itemstable (hash-table-ref/default config "itemstable" #f))) 
					       ;; if either items or items table is a proc return it so test running
					       ;; process can know to call items:get-items-from-config
					       ;; if either is a list and none is a proc go ahead and call get-items
					       ;; otherwise return #f - this is not an iterated test
					       (cond
						((procedure? items)      
						 (debug:print-info 4 "items is a procedure, will calc later")
						 items)            ;; calc later
						((procedure? itemstable)
						 (debug:print-info 4 "itemstable is a procedure, will calc later")
						 itemstable)       ;; calc later
						((filter (lambda (x)
							   (let ((val (car x)))
							     (if (procedure? val) val #f)))







|







385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
						   (itemstable (hash-table-ref/default config "itemstable" #f))) 
					       ;; if either items or items table is a proc return it so test running
					       ;; process can know to call items:get-items-from-config
					       ;; if either is a list and none is a proc go ahead and call get-items
					       ;; otherwise return #f - this is not an iterated test
					       (cond
						((procedure? items)      
						 (debug:print-info 4 "items is a procedure, will calc later") ;; BB? calc later? when??
						 items)            ;; calc later
						((procedure? itemstable)
						 (debug:print-info 4 "itemstable is a procedure, will calc later")
						 itemstable)       ;; calc later
						((filter (lambda (x)
							   (let ((val (car x)))
							     (if (procedure? val) val #f)))
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
			       (begin
				 (debug:print-info 0 "Adding non-itemized test " waiton " to required-tests")
				 (set! required-tests (cons waiton required-tests))
				 (set! test-patts new-test-patts))))
			 (begin
			   (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it")
			   (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests))
			 
		     ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts
		     ;;  - doesn't work
		     ;; (set! test-patts (conc test-patts "," waiton "/"))
		     
		     ;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
		     )))
	     (delete-duplicates (append waitons waitors)))
	    (let ((remtests (delete-duplicates (append waitons tal))))
	      (if (not (null? remtests))
		  (begin

		    ;; (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", "))
		    (loop (car remtests)(cdr remtests))))))))

    (if (not (null? required-tests))
	(debug:print-info 1 "Adding \"" (string-intersperse required-tests " ") "\" to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 "test-records=" (hash-table->alist test-records))
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)
		 (run-queue-retries 5)
		 (th1        (make-thread (lambda ()
					    (handle-exceptions
					     exn







|









|
>
|



|

|







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
			       (begin
				 (debug:print-info 0 "Adding non-itemized test " waiton " to required-tests")
				 (set! required-tests (cons waiton required-tests))
				 (set! test-patts new-test-patts))))
			 (begin
			   (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it")
			   (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests))
                     
		     ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts
		     ;;  - doesn't work
		     ;; (set! test-patts (conc test-patts "," waiton "/"))
		     
		     ;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
		     )))
	     (delete-duplicates (append waitons waitors)))
	    (let ((remtests (delete-duplicates (append waitons tal))))
	      (if (not (null? remtests))
		  (begin ;; BB: by pushing upstream test with item filter to end, downstream tests' items are not filtered when encountered.  This causes chained-waiton/item_seq4 to FAIL.
                    ;;          when test3/%, test2/%, test1/% all items are added to testpatt when instead test4/item.1 should imply test3/item.1, which shold imply test2/item.1 and so on
		    (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", "))
		    (loop (car remtests)(cdr remtests))))))))

    (if (not (null? required-tests))
	(debug:print-info 0 "BB Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ; BB changed 1 to 0
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 0 "BB test-records=" (hash-table->alist test-records)) ; BB: changed 4 to 0
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)
		 (run-queue-retries 5)
		 (th1        (make-thread (lambda ()
					    (handle-exceptions
					     exn

Modified tests.scm from [41a7ac7d26] to [ca4cdd22f6].

182
183
184
185
186
187
188

189
190
191
192
193
194
195
					 (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
				    ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
				    ;; (print "in map, x=" x ", newpatt=" newpatt)
				    newpatt))
				(filter (lambda (x)
					  (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
					patts))))

    (string-intersperse (delete-duplicates (append patts (if (null? patts-waiton)
							     (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
							     patts-waiton)))
			",")))
  
;; tests:glob-like-match 
(define (tests:glob-like-match patt str) 







>







182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
					 (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
				    ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
				    ;; (print "in map, x=" x ", newpatt=" newpatt)
				    newpatt))
				(filter (lambda (x)
					  (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
					patts))))

    (string-intersperse (delete-duplicates (append patts (if (null? patts-waiton)
							     (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
							     patts-waiton)))
			",")))
  
;; tests:glob-like-match 
(define (tests:glob-like-match patt str)