Megatest

Check-in [2d46a2e3ec]
Login
Overview
Comment:Added storage of commands in the server thread hash, added debug prints when the max threads is exceeded
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.81
Files: files | file ages | folders
SHA1: 2d46a2e3ec7c483707258306aec0058e00ff6857
User & Date: mmgraham on 2024-06-27 16:45:21
Other Links: branch diff | manifest | tags
Context
2024-07-01
11:59
Added CSCOPTS entry used for debugging check-in: 74949ef691 user: mrwellan tags: v1.81
10:56
Pulled in testcontrol panel improvements Leaf check-in: f8243ad180 user: mrwellan tags: v1.81-test-control-panel
2024-06-27
16:45
Added storage of commands in the server thread hash, added debug prints when the max threads is exceeded check-in: 2d46a2e3ec user: mmgraham tags: v1.81
2024-06-25
20:26
Updated stepwise flow graph check-in: 24e3d80cf5 user: matt tags: v1.81
Changes

Modified api.scm from [b08fe263c7] to [bf55d9f0a8].

153
154
155
156
157
158
159
160
161








162
163
164
165
166
167
168
169
170
171
172
173
174









175
176
177
178
179
180
181
153
154
155
156
157
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







-
-
+
+
+
+
+
+
+
+













+
+
+
+
+
+
+
+
+







    tasks-set-state-given-param-key
    ))

(define *db-write-mutexes* (make-hash-table))
(define *server-signature* #f)

(define *api-threads* '())
(define (api:register-thread th-in)
  (set! *api-threads* (cons (cons th-in (current-seconds)) *api-threads*)))
(define (api:register-thread th-in command)
  (set! *api-threads* (cons (list th-in (current-seconds) command) *api-threads*)))

(define (api:get-thread-command th-in)
  (let ((thread-data (assoc th-in *api-threads*)))
    (if thread-data
        (third thread-data) ; Assuming the command is the third element in the list
        #f))) ; Return #f if the thread is not found

(define (api:unregister-thread th-in)
  (set! *api-threads* (filter (lambda (thdat)
				(not (eq? th-in (car thdat))))
			      *api-threads*)))

(define (api:remove-dead-or-terminated)
  (set! *api-threads* (filter (lambda (thdat)
				(not (member (thread-state (car thdat)) '(terminated dead))))
			      *api-threads*)))

(define (api:get-count-threads-alive)
  (length *api-threads*))

(define (api:get-threads)
  (map (lambda (thdat)
         (let ((thread (first thdat))
               (timestamp (second thdat))
               (command (third thdat)))
           (format "\nThread: ~a, age: ~a, Command: ~a" thread (- (current-seconds) timestamp) command)))
       *api-threads*))


(define *api:last-stats-print* 0)
(define *api-print-db-stats-mutex* (make-mutex))
(define (api:print-db-stats)
  (debug:print-info 0 *default-log-port* "Started periodic db stats printer")
  (let loop ()
    (mutex-lock! *api-print-db-stats-mutex*)
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







-
+







;;          reads/writes to current in/out port
;;
(define (api:tcp-dispatch-request-make-handler dbstruct) ;; cmd run-id params)
  (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
  (if (not *server-signature*)
      (set! *server-signature* (tt:mk-signature *toppath*)))
  (lambda (indat)
    (api:register-thread (current-thread))
    (api:register-thread (current-thread) (car indat))
    (let* ((result 
	    (let* ((numthreads (api:get-count-threads-alive))
		   (delay-wait (if (> numthreads 10)
				   (- numthreads 10)
				   0))
		   (normal-proc (lambda (cmd run-id params)
				  (case cmd
226
227
228
229
230
231
232
233

234
235
236
237
238
239

240
241
242
243
244
245
246
241
242
243
244
245
246
247

248

249

250
251

252
253
254
255
256
257
258
259







-
+
-

-


-
+







					 ((ping) #t) ;; we are fine
					 (else
					  (assert ok "FATAL: database file and run-id not aligned.")))))
			     (ttdat   *server-info*)
			     (server-state (tt-state ttdat))
			     (maxthreads   20) ;; make this a parameter?
			     (status  (cond
				       ((and (> numthreads maxthreads)
                                       ((> numthreads maxthreads)
					     (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server.
					'busy)
				       ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
				       (else 'ok)))
			     (errmsg  (case status
					((busy)   (conc "Server overloaded, "numthreads" threads in flight"))
					((busy)   (conc "Server overloaded, "numthreads" threads in flight, current cmd: " cmd "\n current threads: " (api:get-threads)))
					((loaded) (conc "Server loaded, "numthreads" threads in flight"))
					(else     #f)))
			     (result  (case status
					((busy)
					 (if (eq? cmd 'ping)
					     (normal-proc cmd run-id params)
					     ;; numthreads must be greater than 5 for busy

Modified tcp-transportmod.scm from [3b34f09355] to [2d80f8e52f].

324
325
326
327
328
329
330

331
332
333
334
335
336
337
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338







+







			 (debug:print 0 *default-log-port* "Server is loaded, delaying "delay-wait" seconds")
			 (thread-sleep! delay-wait)))))
	     (case status
	       ((busy) ;; result will be how long the server wants you to delay
		(let* ((raw-dly  (if (number? result) result 0.1))
		       (dly      (+ raw-dly (/ attemptnum 10)))) ;; (* raw-dly (/ attemptnum 2))))
		  (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is busy, cmd is "cmd", will try again in "dly" seconds. This is attempt "(- attemptnum 1))
                  (debug:print 0 *default-log-port* errmsg)
		  (thread-sleep! dly)
		  (tt:handler  ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc)))
	       ((loaded)
		(debug:print 0 *default-log-port* "WARNING: server for "dbfname" is loaded, slowing queries.")
		(tt:backoff-incr (tt-conn-host conn)(tt-conn-port conn))
		result) ;; (tt:handler  ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe))
	       (else