Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -155,10 +155,38 @@ (append (list 0 *default-log-port* (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) in-args))) (apply debug:print dp-args)))) + +(define *BBprofile-hash* (make-hash-table)) +(define (BBprofile-thunk procname thunk) + (let* ((old-proctally (hash-table-ref/default *BBprofile-hash* procname + '(0 . 0))) + (old-proccalls (car old-proctally)) + (old-procduration (cdr old-proctally)) + (before-ms (current-milliseconds)) + (res (thunk)) + (after-ms (current-milliseconds)) + (duration (/ (- after-ms before-ms) 1000)) + (proccalls (add1 old-proccalls)) + (procduration (+ duration old-procduration))) + (hash-table-set! *BBprofile-hash* procname + (cons proccalls procduration)) + (BB> "@@@@ called "procname" ; duration="duration" ; totcalls="proccalls + " avg="(/ procduration proccalls)" tot="procduration) + res)) +(define (BBprofile . in-args) + (let* ((proc (car in-args)) + (args (cdr in-args)) + (procname (symbol->string (car (procedure-information proc)))) + (thunk (lambda () + (apply proc args)))) + (BBprofile-thunk procname thunk))) + + + (define *BBpp_custom_expanders_list* (make-hash-table)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -1256,10 +1256,11 @@ ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) + (BB> "launch-test entered") (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex (let* ( ;; (lock-key (conc "test-" test-id)) ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key)) ;; (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds ;; (if (car lock) @@ -1280,10 +1281,11 @@ (begin (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay. (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds")) (thread-sleep! (- launch-delay delta)) (loop (- (current-seconds) *last-launch*) launch-delay)))) + (BB> "lt - post delay loop") (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars) (append (list (list "MT_RUN_AREA_HOME" *toppath*) @@ -1336,10 +1338,11 @@ (mt-bindir-path #f) (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) + (BB> "lt - in let1") ;; (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) @@ -1353,16 +1356,19 @@ ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f) + (BB> "lt - set LAUNCHED state") ;; (pp (hash-table->alist tconfig)) (set! diskpath (get-best-disk *configdat* tconfig)) (if diskpath - (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) + (let ((dat (BBprofile create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) + (BB> "lt - created work-area "work-area) + (debug:print-info 2 *default-log-port* "Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) (create-directory work-area #t) (debug:print 0 *default-log-port* "WARNING: No disk work area specified - running in the test directory under tmp_run"))) @@ -1396,11 +1402,11 @@ (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path)))))))) - + (BB> "lt - encoded params") ;; clean out step records from previous run if they exist ;; (rmt:delete-test-step-records run-id test-id) ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway (if (common:file-exists? work-area) (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir @@ -1417,11 +1423,14 @@ ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (debug:print 1 *default-log-port* "Launching " work-area) ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done (debug:print 4 *default-log-port* "fullcmd: " fullcmd) + (BB> "lt - set *last-launch*") (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible. + (BB> "lt - BEFORE LAUNCHER") + (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (append (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) @@ -1433,22 +1442,27 @@ itemdat))) (testprevvals (alist->env-vars (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))) ;; Launchwait defaults to true, must override it to turn off wait (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) - (launch-results (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed. - process:cmd-run-with-stderr->list - process-run) - (if useshell - (let ((cmdstr (string-intersperse fullcmd " "))) - (if launchwait - cmdstr - (conc cmdstr " >> mt_launch.log 2>&1 &"))) - (car fullcmd)) - (if useshell - '() - (cdr fullcmd))))) + (launch-results + (BBprofile-thunk "launchcmd" (lambda () + (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed. + process:cmd-run-with-stderr->list + process-run) + (if useshell + (let ((cmdstr (string-intersperse fullcmd " "))) + (if launchwait + cmdstr + (conc cmdstr " >> mt_launch.log 2>&1 &"))) + (car fullcmd)) + (if useshell + '() + (cdr fullcmd))) + )) + )) + (BB> "lt - AFTER LAUNCHER launchwait="launchwait" useshell="useshell" fullcmd="fullcmd) (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork. ;; (rmt:no-sync-del! lock-key) ;; release the lock for starting this test (if (not launchwait) ;; give the OS a little time to allow the process to start (thread-sleep! 0.01)) (with-output-to-file "mt_launch.log" Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1040,11 +1040,11 @@ (if maxload ;; only gate if maxload is specified (common:wait-for-cpuload maxload numcpus waitdelay)) (if maxhomehostload (common:wait-for-homehost-load maxhomehostload (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload))) - (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) + (BBprofile run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) (runs:incremental-print-results run-id) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) @@ -1614,16 +1614,10 @@ lst)) -(define (run:test-standalone target runname keys keyvals flags) - (let* ((run-id ...) - (run-info ...) - - - ) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step ;; (define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) ;; all-tests-registry - used to determine test path @@ -1786,11 +1780,11 @@ (if skip-test (begin (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test)) - (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) ;; HERE WE GO + (if (not (BBprofile launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) ;; HERE WE GO (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))))) ((KILLED)