Megatest

(cond-expand
 (chicken-4
  ;; chicken 4 stuff here
  (use readline)
  (current-input-port (make-readline-port))
  (install-history-file #f "/.csi.history")
  )
 (chicken-5
  (import (chicken load))
  (import (chicken format))
  (import (chicken process-context))
  (import (chicken process signal))
  (load-verbose #f)
  (let ()
    (unless (get-environment-variable "INSIDE_EMACS")
      (import breadline)
      (import breadline-scheme-completion)
      (history-file (format "~a/.csi_history" (get-environment-variable "HOME")))
      (stifle-history! 10000)
      (completer-word-break-characters-set! "\"\'`;|(")
      (completer-set! scheme-completer)
      (basic-quote-characters-set! "\"|")
      (variable-bind! "blink-matching-paren" "on")
      (paren-blink-timeout-set! 200000)
      (let ((handler (signal-handler signal/int)))
	(set-signal-handler! signal/int
			     (lambda (s)
			       (cleanup-after-signal!)
			       (reset-after-signal!)
			       (handler s))))
      (on-exit reset-terminal!)
      (current-input-port (make-readline-port))))
  ))

;; NB// area-dat replaced by ttdat
;; 
(define (rmt:send-receive cmd run-id params #!key (attemptnum 1)(ttdat #f))
  (assert (or (not run-id) (number? run-id)) "FATAL: run-id is required to be a number or #f")
  (assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.")
  (let* ((areapath      *toppath*) ;; TODO - resolve from dbstruct to be compatible with multiple areas
	 (readonly-mode (rmtmod:calc-ro-mode ttdat *toppath*))
	 (testsuite     (common:get-testsuite-name))
	 (dbfname       (conc (dbfile:run-id->dbnum run-id)".db"))
	 (dbdir         (conc areapath "/.mtdb")))
    (if (and (not *journal-stats*)
	     (file-exists? dbdir))
	(tt:start-stats dbdir)) ;; fixme - find the right call to get the db directory
    
    ;; check the load on dbfname and add some delay using a droop curve of sorts
    (if *journal-stats*
	(let* ((stats (tt:get-journal-stats))
	       (load  (or (alist-ref dbfname stats equal?) 0)))
	  (if (> load 0)
	      (let ((dely (* 10 load)))
		(debug:print 0 *default-log-port* "Journal load "load" delaying queries "dely"s.")
		(thread-sleep! dely)))))
	
    (case (rmt:transport-mode)
      ((tcp)
       (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
	      (attemptnum    (+ 1 attemptnum))
	      (mtexe         (common:find-local-megatest))

	      (ttdat         (rmt:set-ttdat areapath ttdat))
	      (conn          (tt:get-conn ttdat dbfname))
	      (is-main       (equal? dbfname "main.db")) ;; why not (not run-id) ?
	      (server-start-proc (if is-main
				     #f
				     (lambda ()
				       ;; (debug:print-info 0 *default-log-port* "starting server for dbfname: "dbfname)

	 (registry-mutex         (runs:dat-registry-mutex runsdat))
	 (flags                  (runs:dat-flags runsdat))
	 (keyvals                (runs:dat-keyvals runsdat))
	 (run-info               (runs:dat-run-info runsdat))
	 (all-tests-registry     (runs:dat-all-tests-registry runsdat))
	 (run-limits-info        (runs:dat-can-run-more-tests runsdat))
	 ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 (have-resources         (and (if *journal-stats*
					  (let* ((dbfname (conc
							   (dbfile:run-id->dbnum run-id)
							   ".db"))
						 (stats (tt:get-journal-stats))
						 (load  (or (alist-ref dbfname stats equal?) 0)))
					    (if (> load 0.1) ;; dbs too busy to start more tests
						(begin
						 (debug:print-info 0 *default-log-port* "Gating launch due to db load "load" based on journal file observations for "dbfname)
						 #f)
						#t))
					  #t) ;; if journal monitoring not started do not gate
				      (car run-limits-info)))
	 (num-running            (list-ref run-limits-info 1))
	 (num-running-in-jobgroup(list-ref run-limits-info 2)) 
	 (max-concurrent-jobs    (list-ref run-limits-info 3))
	 (job-group-limit        (list-ref run-limits-info 4))
	 ;; (prereqs-not-met        (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
	 ;; (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails                  (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs

	  extras
	  hostinfo

	  ports
	  posix
	  files
	  data-structures
	  directory-utils
	  tcp
	  ))
 (chicken-5
  (import chicken.base
	  chicken.condition
	  chicken.file
	  chicken.pathname

  (sort (get-all-ips) ip-pref-less?))

(define (get-all-ips)
  (map address-info-host
       (filter (lambda (x)
		 (equal? (address-info-type x) "tcp"))
	       (address-infos (get-host-name)))))

;;======================================================================
;; Other Utils
;;======================================================================

(defstruct jstats
  (count 0)
  (jcount (make-hash-table)) ;; 1.db => journal_count
  )

;; timeblk => jstats
(define *journal-stats* #f) ;; (make-hash-table))

;; monte-carlo-esque random sampling of journal files
;; for all the files:
;;   if .journal
;;      update stats +1 +1
;;      update stats +1  0
;;
(define (tt:write-load-tracking dbdir)
  (let* ((cs    (current-seconds))
	 (key   (inexact->exact (quotient cs 10)))
	 (old   (- key 5)) ;; 4 x 10 seconds ago
	 (jstat (if (hash-table-exists? *journal-stats* key)
		    (hash-table-ref *journal-stats* key )
		    (let ((new (make-jstats)))
		      (hash-table-set! *journal-stats* key new)
		      new))))
    ;; clear out old records
    (for-each
     (lambda (key)
       (if (< key old)
	   (hash-table-delete! *journal-stats* key)))
     (hash-table-keys *journal-stats*))

    ;; increment our count of observations
    (jstats-count-set! jstat (+ (jstats-count jstat) 1))
    
    ;; now find and increment journal file counts
    (directory-fold
     (lambda (fname res)
       ;; is it a journal file?
       (let ((parts (string-match "^(.*\\.db)-journal.*" fname)))
	 (match parts
	   ((_ dbfname)
	    (hash-table-set! (jstats-jcount jstat) dbfname
			     (+ (hash-table-ref/default (jstats-jcount jstat) dbfname 0) 1)
			     ))
	   (else #f)
	   )))
     '()
     dbdir 
     )))

(define *journal-stats-mutex* (make-mutex))

(define (tt:journal-stats-run dbdir)
  (if (not *journal-stats*)(set! *journal-stats* (make-hash-table)))
  (let loop ()
    (mutex-lock! *journal-stats-mutex*)
    (tt:write-load-tracking dbdir)
    (mutex-unlock! *journal-stats-mutex*)
    (thread-sleep! (/ (random 1000) 100.0))
    (loop)))

;; call this to start a thread that is keeping the journal-stats up to date.
(define (tt:start-stats dbdir)
  
  (thread-start!
   (make-thread
    (lambda ()(tt:journal-stats-run dbdir)) "Journal stats collection thread")))

(define (tt:get-journal-stats)
  (let* ((result    (make-jstats))
	 (hitcounts (jstats-jcount result)))
    (if *journal-stats*
	(begin
	  (mutex-lock! *journal-stats-mutex*)
	  (hash-table-for-each
	   *journal-stats*
	   (lambda (k v) ;; key jstats
	     (let* ((count  (jstats-count v))
		    (jcount (jstats-jcount v))) ;; dbfname => hit count
	       (jstats-count-set! result
				  (+ (jstats-count result)
				     (jstats-count v)))
	       (hash-table-for-each
		jcount
		(lambda (dbfname hit-count)
		  (hash-table-set! hitcounts dbfname
				   (+ hit-count
				      (hash-table-ref/default hitcounts dbfname 0))))))))
	  (mutex-unlock! *journal-stats-mutex*))
	(debug:print 0 *default-log-port* "INFO: *journal-stats* not set."))
    ;; convert to normalized alist
    (let ((tot  (min (jstats-count result) 1)) ;; avoid divide by zero
	  (hits (jstats-jcount result))) ;; 1.db => count
      (hash-table-map
       hits
       (lambda (fname hitcount)
	 (cons fname (/ hitcount tot)))))))

;; megatest> (import tcp-transportmod)
;; megatest> (tt:write-load-tracking ".mtdb")
;; megatest> (hash-table-keys *journal-stats*)
;; (172060297)
;; megatest> (jstats->alist (hash-table-ref *journal-stats* 172060297))
;; ((count . 1) (jcount . #<hash-table (1)>))
;; megatest> (jstats-jcount (hash-table-ref *journal-stats* 172060297))
;; #<hash-table (1)>
;; megatest> (hash-table->alist (jstats-jcount (hash-table-ref *journal-stats* 172060297)))
;; (("1.db" . 4))

)