Megatest

Check-in [6fed2d60a6]
Login
Overview
Comment:Implemented server thread count throttling of launches, miminally tested.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.81-multi-server
Files: files | file ages | folders
SHA1: 6fed2d60a68968459638abf3eabc40c8bc3ed554
User & Date: mrwellan on 2024-07-08 10:24:18
Other Links: branch diff | manifest | tags
Context
2024-07-09
08:53
Merged from v1.81 and fixed conflicts Leaf check-in: dbc22912d1 user: mrwellan tags: v1.81-multi-server
2024-07-08
10:24
Implemented server thread count throttling of launches, miminally tested. check-in: 6fed2d60a6 user: mrwellan tags: v1.81-multi-server
06:01
wip (still broke) check-in: 00c25a6b53 user: matt tags: v1.81-multi-server
Changes

Modified tcp-transportmod.scm from [571bf1ec6b] to [f03b836e05].

218
219
220
221
222
223
224
225

226
227
228
229
230
231
232
218
219
220
221
222
223
224

225
226
227
228
229
230
231
232







-
+







				     (lambda (a b)
				       (let* ((load-a (tt:get-server-threads a))
					      (load-b (tt:get-server-threads b)))
					 (< load-a load-b))))))))
				     
	  ;; (let ((indx (max (random (- (length sdats) 1)) 0)))
	  ;;    (list-ref sdats indx)))))
	  (debug:print-info 1 *default-log-port* "found sdat " sdat" from sdats: "sdats)
	  ;; (debug:print-info 1 *default-log-port* "found sdat " sdat" from sdats: "sdats)
          (match sdat
	    ((host port start-time server-id pid dbfname2 servinffile)
	     (assert (equal? dbfname dbfname2) "FATAL: read server info from wrong file.")
             (debug:print-info 2 *default-log-port* "no conn - in match servinffile:" servinffile)
	     (let* ((host-port (conc host":"port))
		    (conn (make-tt-conn
			   host: host
293
294
295
296
297
298
299
300
301
302
303




304
305
306
307
308
309
310
293
294
295
296
297
298
299




300
301
302
303
304
305
306
307
308
309
310







-
-
-
-
+
+
+
+








(define (tt:save-server-meta host port meta)
  (hash-table-set! *server-load* (conc host":"port) (cons meta (current-seconds))))

(define (tt:get-server-threads dat)
  (let* ((host (car  dat))
	 (port (cadr dat))
	 (dat  (tt:get-server-meta host port #t))
	 (meta (if dat (car dat) #f)))
    (if (list? meta)
	(or (alist-ref 'sload meta) 99998)
	 (dat  (tt:get-server-meta host port #t)))
    ;; (debug:print 0 *default-log-port* "host: "host" port: "port" dat: "dat)
    (if (list? dat)
	(or (alist-ref 'sload dat) 99998)
	99999))) ;; absurd number means don't use this one

;; lazy get, does not auto-refresh meta, this might be a problem
;;
(define (tt:get-server-meta host port #!optional (do-ping #f))
  (let* ((get-meta (lambda ()
		     (let* ((dat  (hash-table-ref/default *server-load* (conc host":"port) #f)))
321
322
323
324
325
326
327
328
329
330
331
332
333








334
335
336
337
338
339
340
321
322
323
324
325
326
327






328
329
330
331
332
333
334
335
336
337
338
339
340
341
342







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







  (if ttdat ;; if no server yet just pass on through
      (let* ((dbfname                 (dbmod:run-id->dbfname run-id))
	     (get-lowest-thread-load
	      (lambda ()
		(let* ((sdats (tt:get-server-info-sorted ttdat dbfname)))
		  (car (map tt:get-server-threads sdats))))))
	(if ttdat
	    (let loop ()
	      (if (> (get-lowest-thread-load) 5) ;; load is pretty high
		  (begin
		    (debug:print 0 *default-log-port* "Servers appear overloaded, waiting...")
		    (thread-sleep! 1)
		    (loop))))
	    (let loop ((count 0))
	      (let* ((lowestload (get-lowest-thread-load)))
		(if (> lowestload 5) ;; load is pretty high
		    (begin
		      (debug:print 0 *default-log-port* "Servers appear overloaded with "lowestload" threads, waiting...")
		      (thread-sleep! 1)
		      (if (< count 10)
			  (loop (+ count 1)))))))
	    (debug:print 0 *default-log-port* "Can't wait on server load, *ttdat* not set")))))

(define (tt:ping host port server-id #!optional (tries-left 5))
  (let*  ((res      (tt:send-receive-direct host port `(ping #f #f #f) ping-mode: #t)) ;; please send me your server-id
	  (try-again (lambda ()
		       (if (> tries-left 0)
			   (begin