Megatest

Check-in [1ed38c9098]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Cleaned up tabdat using defstruct properly and switched to typed-records
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: 1ed38c9098a4f03aac6ce2544bc63e28bcdb8e6a
User & Date: mrwellan on 2016-07-27 13:47:23
Other Links: branch diff | manifest | tags
Context
2016-07-27
17:12
Switched vg to use typed-records check-in: b098e2c6cb user: mrwellan tags: v1.61
13:47
Cleaned up tabdat using defstruct properly and switched to typed-records check-in: 1ed38c9098 user: mrwellan tags: v1.61
2016-07-26
16:22
Added first point check-in: 34979b6b32 user: mrwellan tags: v1.61
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dashboard.scm from [c5b55537e1] to [4da921bbb0].

︙︙
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

(use format)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 defstruct sparse-vectors)
(import (prefix sqlite3 sqlite3:))

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))








|








12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

(use format)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))
︙︙
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
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
295
296
297
298
299
300
301
302
303
304

		     tnum
		     (cons updater curr-updaters))))

;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  allruns          ;; list of dboard:rundat records
  allruns-by-id    ;; hash of run-id -> dboard:rundat records
  done-runs        ;; list of runs already drawn
  not-done-runs    ;; list of runs not yet drawn
  header           ;; header for decoding the run records
  keys             ;; keys for this run (i.e. target components)
  numruns
  tot-runs
  last-data-update ;; last time the data in allruns was updated
  runs-mutex       ;; use to prevent parallel access to draw objects

  ;; Runs view
  buttondat 
  item-test-names
  run-keys
  runs-matrix       ;; used in newdashboard
  start-run-offset  ;; left-right slider value
  start-test-offset ;; up-down slider value

  ;; Canvas and drawing data
  cnv
  cnv-obj
  drawing
  draw-cache     ;; 
  start-row
  run-start-row
  max-row
  running-layout
  originx
  originy
  layout-update-ok
  compact-layout

  ;; Controls used to launch runs etc.
  command          ;; for run control this is the command being built up
  command-tb 
  key-listboxes
  key-lbs           
  run-name         ;; from run name setting widget
  states           ;; states for -state s1,s2 ...
  statuses         ;; statuses for -status s1,s2 ...

  ;; Selector variables
  curr-run-id      ;; current row to display in Run summary view
  curr-test-ids    ;; used only in dcommon:run-update which is used in newdashboard
  filters-changed  ;; to to indicate that the user changed filters for this tab
  last-filter-str  ;; conc the target runname and testpatt for a signature of changed filters
  hide-empty-runs
  hide-not-hide    ;; toggle for hide/not hide empty runs
  hide-not-hide-button
  searchpatts
  state-ignore-hash    ;; hash of  STATE => #t/#f for display control
  status-ignore-hash   ;; hash of STATUS => #t/#f
  target
  test-patts

  ;; db info to file the .db files for the area
  dbdir
  dbfpath
  dbkeys 
  last-db-update  ;; last db file timestamp
  monitor-db-path ;; where to find monitor.db
  ro               ;; is the database read-only?

  ;; tests data
  num-tests        ;; total number of tests to show (used in the old runs display)

  ;; runs tree
  path-run-ids     ;; path (target / runname) => id
  runs-tree

  ;; tab data
  last-update      ;; last time this tab was updated
  view-changed
  xadj             ;; x slider number (if using canvas)
  yadj             ;; y slider number (if using canvas)

  tests-tree       ;; used in newdashboard
  )

(define (dboard:tabdat-target-string vec)
  (let ((targ (dboard:tabdat-target vec)))
    (if (list? targ)(string-intersperse targ "/") "no-target-specified")))

(define (dboard:tabdat-test-patts-use vec)    
  (let ((val (dboard:tabdat-test-patts vec)))(if val val "")))

;; additional setters for dboard:data
(define (dboard:tabdat-test-patts-set!-use    vec val)
  (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))

(define (dboard:tabdat-make-data)
  (let ((dat (make-dboard:tabdat
	      allruns-by-id:        (make-hash-table)
	      allruns:              '() ;; list of run records (vectors)
	      buttondat:            (make-hash-table)
	      curr-test-ids:        (make-hash-table)
	      command:              ""
	      compact-layout:       #t
	      dbdir:                #f
	      filters-changed:      #f
	      header:               #f 
	      hide-empty-runs:      #f
	      hide-not-hide-button: #f
	      hide-not-hide:        #t
	      item-test-names:      '()
	      keys:                 #f
	      key-listboxes:        #f
	      last-db-update:       0
	      last-data-update:     0
	      layout-update-ok:     #t
	      not-done-runs:        '()
	      done-runs:            '()
	      num-tests:            15
	      numruns:              16
	      originx:              #f
	      originy:              #f
	      path-run-ids:         (make-hash-table)
	      run-ids:              (make-hash-table)
	      run-keys:             (make-hash-table)
	      running-layout:       #f
	      searchpatts:          (make-hash-table)
	      start-run-offset:     0
	      start-test-offset:    0
	      state-ignore-hash:    (make-hash-table)
	      status-ignore-hash:   (make-hash-table)
	      xadj:                 0
	      yadj:                 0
	      view-changed:         #t
	      run-start-row:        0
	      max-row:              0
	      runs-mutex:           (make-mutex)
	      )))
    (dboard:setup-tabdat dat)
    (dboard:setup-num-rows dat)
    dat))

(define (dboard:setup-tabdat tabdat)
  (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))








|
|
|
|
|
|
|
|
|
|


|
|
|
|
|
|


|
|
|
<
<
|
|
|
|
|
|
|


|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|
|
|
|
|


|


|
|


<
|
|
|
















|
<
<
<
|
|
<
|
|
<
|
|
|
<
<
|
|
<
<
<
<
|
<
|
|
|
|
|
<
|
<
|
|
|
|
|
|
<
<
<
|








158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187


188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234

235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254



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

		     tnum
		     (cons updater curr-updaters))))

;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  ((allruns         '())                 : list)        ;; list of dboard:rundat records
  ((allruns-by-id    (make-hash-table))  : hash-table)  ;; hash of run-id -> dboard:rundat records
  ((done-runs       '())                 : list)        ;; list of runs already drawn
  ((not-done-runs   '())                 : list)        ;; list of runs not yet drawn
  (header            #f)                                ;; header for decoding the run records
  (keys              #f)                                ;; keys for this run (i.e. target components)
  ((numruns          16)                 : number)      ;; 
  ((tot-runs          0)                 : number)
  ((last-data-update  0)                 : number)      ;; last time the data in allruns was updated
  (runs-mutex         (make-mutex))                     ;; use to prevent parallel access to draw objects

  ;; Runs view
  ((buttondat         (make-hash-table)) : hash-table)  ;;     
  ((item-test-names  '())                : list)        
  ((run-keys          (make-hash-table)) : hash-table)
  (runs-matrix        #f)                               ;; used in newdashboard
  ((start-run-offset   0)                : number)      ;; left-right slider value
  ((start-test-offset  0)                : number)      ;; up-down slider value

  ;; Canvas and drawing data
  (cnv                #f)
  (cnv-obj            #f)
  (drawing            #f)


  ((run-start-row     0)                 : number)
  ((max-row           0)                 : number)
  ((running-layout    #f)                : boolean)
  (originx            #f)
  (originy            #f)
  ((layout-update-ok  #t)                : boolean)
  ((compact-layout    #t)                : boolean)

  ;; Controls used to launch runs etc.
  ((command          "")                 : string)      ;; for run control this is the command being built up
  (command-tb        #f)			         
  (key-listboxes     #f)			         
  (key-lbs           #f)			         
  run-name                                              ;; from run name setting widget
  states                                                ;; states for -state s1,s2 ...
  statuses                                              ;; statuses for -status s1,s2 ...
						         
  ;; Selector variables				         
  curr-run-id                                           ;; current row to display in Run summary view
  curr-test-ids                                         ;; used only in dcommon:run-update which is used in newdashboard
  ((filters-changed  #f)                 : boolean)     ;; to to indicate that the user changed filters for this tab
  ((last-filter-str  "")                 : string)      ;; conc the target runname and testpatt for a signature of changed filters
  ((hide-empty-runs  #f)                 : boolean)     
  ((hide-not-hide    #t)                 : boolean)     ;; toggle for hide/not hide empty runs
  (hide-not-hide-button #f)
  ((searchpatts      (make-hash-table))  : hash-table)  ;;
  ((state-ignore-hash (make-hash-table)) : hash-table)  ;; hash of  STATE => #t/#f for display control
  ((status-ignore-hash (make-hash-table)) : hash-table)  ;; hash of STATUS => #t/#f
  (target              #f)
  (test-patts          #f)

  ;; db info to file the .db files for the area
  (dbdir               #f)
  (dbfpath             #f)
  (dbkeys              #f)
  ((last-db-update     0)                : number)      ;; last db file timestamp
  (monitor-db-path     #f)                              ;; where to find monitor.db
  ro                                                    ;; is the database read-only?

  ;; tests data
  ((num-tests          10)               : number)      ;; total number of tests to show (used in the old runs display)

  ;; runs tree
  ((path-run-ids       (make-hash-table)) : hash-table) ;; path (target / runname) => id
  (runs-tree           #f)

  ;; tab data

  ((view-changed       #t)                : boolean)   
  ((xadj               0)                 : number)     ;; x slider number (if using canvas)
  ((yadj               0)                 : number)     ;; y slider number (if using canvas)

  tests-tree       ;; used in newdashboard
  )

(define (dboard:tabdat-target-string vec)
  (let ((targ (dboard:tabdat-target vec)))
    (if (list? targ)(string-intersperse targ "/") "no-target-specified")))

(define (dboard:tabdat-test-patts-use vec)    
  (let ((val (dboard:tabdat-test-patts vec)))(if val val "")))

;; additional setters for dboard:data
(define (dboard:tabdat-test-patts-set!-use    vec val)
  (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))

(define (dboard:tabdat-make-data)
  (let ((dat (make-dboard:tabdat)))



    ;; 	      curr-test-ids:        (make-hash-table)
    ;; 	      command:              ""

    ;; 	      dbdir:                #f
    ;; 	      filters-changed:      #f

    ;; 	      hide-empty-runs:      #f
    ;; 	      hide-not-hide-button: #f
    ;; 	      hide-not-hide:        #t


    ;; 	      key-listboxes:        #f
    ;; 	      last-db-update:       0




    ;; 	      num-tests:            15

    ;; 	      originx:              #f
    ;; 	      originy:              #f
    ;; 	      path-run-ids:         (make-hash-table)
    ;; 	      run-ids:              (make-hash-table)
    ;; 	      run-keys:             (make-hash-table)

    ;; 	      searchpatts:          (make-hash-table)

    ;; 	      start-test-offset:    0
    ;; 	      state-ignore-hash:    (make-hash-table)
    ;; 	      status-ignore-hash:   (make-hash-table)
    ;; 	      xadj:                 0
    ;; 	      yadj:                 0
    ;; 	      view-changed:         #t



    ;; 	      )))
    (dboard:setup-tabdat dat)
    (dboard:setup-num-rows dat)
    dat))

(define (dboard:setup-tabdat tabdat)
  (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
︙︙
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533

	 (run-dat    (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
			(if rec 
			    rec
			    (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
			      (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
			      rd))))
	 ;; (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
	 (last-update (dboard:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
	 (tmptests    (rmt:get-tests-for-run run-id testnamepatt states statuses  ;; run-id testpatt states statuses
					     #f #f                                ;; offset limit 
					     (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					     sort-by                              ;; sort-by
					     sort-order                           ;; sort-order
					     #f ;; 'shortlist                           ;; qrytype
					     (if (dboard:tabdat-filters-changed tabdat) 








|








499
500
501
502
503
504
505
506
507
508
509
510
511
512
513

	 (run-dat    (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
			(if rec 
			    rec
			    (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
			      (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
			      rd))))
	 ;; (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
	 (last-update (dboard:rundat-last-update run-dat)) ;; (vector-ref prev-dat 3))
	 (tmptests    (rmt:get-tests-for-run run-id testnamepatt states statuses  ;; run-id testpatt states statuses
					     #f #f                                ;; offset limit 
					     (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					     sort-by                              ;; sort-by
					     sort-order                           ;; sort-order
					     #f ;; 'shortlist                           ;; qrytype
					     (if (dboard:tabdat-filters-changed tabdat)
︙︙

Modified runs.scm from [b6e930b10f] to [ebd49f8fab].

︙︙
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98

	(setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE")  "/"
					(getenv "MT_TARGET")    "/"
					(getenv "MT_RUNNAME")   "/"
					(getenv "MT_TEST_NAME")
					(if (and itempath
						 (not (equal? itempath "")))
					    (conc "/" itempath)
					    ""))))
    ))

(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))









|
<








83
84
85
86
87
88
89
90

91
92
93
94
95
96
97

	(setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE")  "/"
					(getenv "MT_TARGET")    "/"
					(getenv "MT_RUNNAME")   "/"
					(getenv "MT_TEST_NAME")
					(if (and itempath
						 (not (equal? itempath "")))
					    (conc "/" itempath)
					    ""))))))


(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))
︙︙
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159

	  (hash-table-set! *runs:denoise* key currtime)
	  #t)
	#f)))

(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)
  (thread-sleep! (cond
        	  ((> *runs:can-run-more-tests-count* 20)
		   (if (runs:lownoise "waiting on tasks" 60)
		       (debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
		   2);; obviously haven't had any work to do for a while
        	  (else 0)))
  (let* ((num-running             (rmt:get-count-tests-running run-id))
	 (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
	 (job-group-limit         (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
				    (if (string? jobg-count)
					(string->number jobg-count)
					jobg-count))))
    (if (> (+ num-running num-running-in-jobgroup) 0)
	(set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
    (if (not (eq? *last-num-running-tests* num-running))
	(begin
	  (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
	  (set! *last-num-running-tests* num-running)))
    (if (not (eq? 0 *globalexitstatus*))
	(list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)
	(let ((can-not-run-more (cond
				 ;; if max-concurrent-jobs is set and the number running is greater 
				 ;; than it than cannot run more jobs
				 ((and max-concurrent-jobs (>= num-running max-concurrent-jobs))
				  (if (runs:lownoise "mcj msg" 60)
				      (debug:print 0 *default-log-port* "WARNING: Max running jobs exceeded, current number running: " num-running 
						   ", max_concurrent_jobs: " max-concurrent-jobs))
				  #t)
				 ;; if job-group-limit is set and number of jobs in the group is greater
				 ;; than the limit then cannot run more jobs of this kind








<
|


















|








124
125
126
127
128
129
130

131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157

	  (hash-table-set! *runs:denoise* key currtime)
	  #t)
	#f)))

(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)
  (thread-sleep! (cond
        	  ((> *runs:can-run-more-tests-count* 20)

		   (if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
		   2);; obviously haven't had any work to do for a while
        	  (else 0)))
  (let* ((num-running             (rmt:get-count-tests-running run-id))
	 (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
	 (job-group-limit         (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
				    (if (string? jobg-count)
					(string->number jobg-count)
					jobg-count))))
    (if (> (+ num-running num-running-in-jobgroup) 0)
	(set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
    (if (not (eq? *last-num-running-tests* num-running))
	(begin
	  (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
	  (set! *last-num-running-tests* num-running)))
    (if (not (eq? 0 *globalexitstatus*))
	(list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)
	(let ((can-not-run-more (cond
				 ;; if max-concurrent-jobs is set and the number running is greater 
				 ;; than it then cannot run more jobs
				 ((and max-concurrent-jobs (>= num-running max-concurrent-jobs))
				  (if (runs:lownoise "mcj msg" 60)
				      (debug:print 0 *default-log-port* "WARNING: Max running jobs exceeded, current number running: " num-running 
						   ", max_concurrent_jobs: " max-concurrent-jobs))
				  #t)
				 ;; if job-group-limit is set and number of jobs in the group is greater
				 ;; than the limit then cannot run more jobs of this kind
︙︙

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