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 Side-by-Side 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

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)
(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

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 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
  ((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 
  item-test-names
  run-keys
  runs-matrix       ;; used in newdashboard
  start-run-offset  ;; left-right slider value
  start-test-offset ;; up-down slider value
  ((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
  cnv-obj
  drawing
  (cnv                #f)
  (cnv-obj            #f)
  (drawing            #f)
  draw-cache     ;; 
  start-row
  run-start-row
  max-row
  running-layout
  originx
  originy
  layout-update-ok
  compact-layout
  ((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          ;; 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
  ((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
  dbfpath
  dbkeys 
  last-db-update  ;; last db file timestamp
  monitor-db-path ;; where to find monitor.db
  ro               ;; is the database read-only?
  (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        ;; total number of tests to show (used in the old runs display)
  ((num-tests          10)               : number)      ;; total number of tests to show (used in the old runs display)

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

  ;; 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)
  ((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
  (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:              ""
    ;; 	      curr-test-ids:        (make-hash-table)
    ;; 	      command:              ""
	      compact-layout:       #t
	      dbdir:                #f
	      filters-changed:      #f
    ;; 	      dbdir:                #f
    ;; 	      filters-changed:      #f
	      header:               #f 
	      hide-empty-runs:      #f
	      hide-not-hide-button: #f
	      hide-not-hide:        #t
    ;; 	      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
    ;; 	      key-listboxes:        #f
    ;; 	      last-db-update:       0
	      last-data-update:     0
	      layout-update-ok:     #t
	      not-done-runs:        '()
	      done-runs:            '()
	      num-tests:            15
    ;; 	      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)
    ;; 	      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)
    ;; 	      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
    ;; 	      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))
︙
519
520
521
522
523
524
525
526

527
528
529
530
531
532
533

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:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
	 (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

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

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 ..."))
		   (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
				 ;; 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