90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
;; 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)))
(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))
(dbfname (conc (dbfile:run-id->dbnum run-id)".db"))
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
<
|
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
;; 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* ((load (tt:get-journal-stats dbfname)))
(if (> load 0.1) ;; start activating delay at 10% journal load time
(let ((dely (* 50 (* load load)))) ;; 100% journal time=50sec delay
(debug:print 0 *default-log-port* "Journal load "load" on "dbfname" 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)
|
714
715
716
717
718
719
720
721
722
723
724
725
726
727
|
(define (rmt:no-sync-del! var)
(rmt:send-receive 'no-sync-del! #f `(,var)))
(define (rmt:no-sync-get-lock keyname)
(rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
;; process registration
(define (rmt:register-process host port pid starttime status purpose dbname mtversion)
(rmt:send-receive 'register-process #f (list host port pid starttime status purpose dbname mtversion)))
(define (rmt:set-process-done host pid reason)
(rmt:send-receive 'set-process-done #f (list host pid reason)))
|
>
>
>
>
>
>
>
>
>
|
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
|
(define (rmt:no-sync-del! var)
(rmt:send-receive 'no-sync-del! #f `(,var)))
(define (rmt:no-sync-get-lock keyname)
(rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
(define (rmt:no-sync-add-job host-type vars-list exekey cmdline)
(rmt:send-receive 'no-sync-add-job #f `(,host-type ,vars-list ,exekey ,cmdline)))
(define (rmt:no-sync-take-job host-type)
(rmt:send-receive 'no-sync-take-job #f `(,host-type)))
(define (rmt:no-sync-job-records-clean)
(rmt:set-receive 'no-sync-job-records-clean #f '()))
;; process registration
(define (rmt:register-process host port pid starttime status purpose dbname mtversion)
(rmt:send-receive 'register-process #f (list host port pid starttime status purpose dbname mtversion)))
(define (rmt:set-process-done host pid reason)
(rmt:send-receive 'set-process-done #f (list host pid reason)))
|
788
789
790
791
792
793
794
|
(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
(let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))
(test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
(rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
;;call end of eud of run detection for posthook
(launch:end-of-run-check run-id)))
|
>
>
>
|
810
811
812
813
814
815
816
817
818
819
|
(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
(let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))
(test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
(rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
;;call end of eud of run detection for posthook
(launch:end-of-run-check run-id)))
;; orphaned from cherrypick merge
;; (debug:print 0 *default-log-port* "Inserting " (length tests-data) " tests in run " runname)
|