mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
185 lines
8.2 KiB
Common Lisp
185 lines
8.2 KiB
Common Lisp
|
|
(let ((*evaluator-mode* :compile))
|
|
(with-compilation-unit () (load"run-tests")))
|
|
|
|
(in-package run-tests)
|
|
(pop *posix-argv*)
|
|
(defvar *logdir* (pop *posix-argv*))
|
|
(defvar *njobs* (parse-integer (pop *posix-argv*)))
|
|
(require :sb-posix)
|
|
|
|
(import '(sb-alien:alien-funcall sb-alien:extern-alien
|
|
sb-alien:int sb-alien:c-string sb-alien:unsigned))
|
|
|
|
;;; Ordered approximately in descending order by running time
|
|
(defvar *slow-tests* '("threads.impure"
|
|
"seq.impure"
|
|
"threads.pure"
|
|
"compiler.pure"
|
|
"timer.impure"
|
|
"bug-1180102.impure"
|
|
"gethash-concurrency.impure"
|
|
"arith-slow.pure"))
|
|
|
|
(defvar *filter* nil)
|
|
(defun choose-order (tests)
|
|
(when *filter*
|
|
(let (strings)
|
|
(with-open-file (file *filter*)
|
|
(loop (let ((line (read-line file nil)))
|
|
(if line (push line strings) (return)))))
|
|
(setq tests (remove-if (lambda (x) (not (find x strings :test #'string=)))
|
|
tests))))
|
|
(sort tests
|
|
(lambda (a b)
|
|
(let ((posn-a (or (position a *slow-tests* :test #'string=)
|
|
most-positive-fixnum))
|
|
(posn-b (or (position b *slow-tests* :test #'string=)
|
|
most-positive-fixnum)))
|
|
(cond ((< posn-a posn-b) t)
|
|
((> posn-a posn-b) nil)
|
|
(t (string< a b)))))))
|
|
|
|
(defun output-metrics (c1 c2 c3 c4 testfile comment metricsfile)
|
|
(let ((summary
|
|
;; FORMAT NIL produces simple-base-string when it can
|
|
(format nil "(~10d ~10d ~10d ~10d ~s ~s)~%"
|
|
c1
|
|
c2
|
|
c3
|
|
c4
|
|
testfile
|
|
comment)))
|
|
(sb-unix:unix-write metricsfile summary 0 (length summary))))
|
|
|
|
;; Conversion factor from nanoseconds to internal-time-units
|
|
(defconstant divisor (/ 1000000000 internal-time-units-per-second))
|
|
|
|
(defun sort-metrics (filename)
|
|
(let (original-list)
|
|
(with-open-file (f (make-pathname :type "lisp-expr" :defaults filename))
|
|
(loop (let ((expr (read f nil)))
|
|
(unless expr (return))
|
|
(destructuring-bind (a b c d name pf) expr
|
|
(let ((vt-less-compiler (- d (round (+ a b) divisor))))
|
|
(push (cons vt-less-compiler expr) original-list))))))
|
|
(with-open-file (f (make-pathname :type "txt" :defaults filename)
|
|
:direction :output :if-exists :supersede)
|
|
(format f "
|
|
; Version: ~A
|
|
; Parallelism: ~D
|
|
; Files: ~D
|
|
;
|
|
; COMPILE- COMPILE GC Total Less
|
|
; FILE compiler
|
|
; (thread) (thread) (process)
|
|
; virtual virtual real virtual virtual
|
|
; --------- ---------- -------- ---------- ----------
|
|
" (lisp-implementation-version) *njobs* (length original-list))
|
|
|
|
(let ((c1 0) (c2 0) (c3 0) (c4 0) (c5 0))
|
|
(dolist (line (sort original-list #'> :key #'car))
|
|
(destructuring-bind (net cfile compile gc process filename pf) line
|
|
;; get-internal-run-time returns microseconds
|
|
;; but we've collected the compiler time in nanoseconds
|
|
(setq cfile (round cfile divisor)
|
|
compile (round compile divisor))
|
|
(format f "~11d~12d~10d~12d~12d ~A~A~%"
|
|
cfile compile gc process net filename (if (eql pf :fail) " FAIL" ""))
|
|
(incf c1 cfile)
|
|
(incf c2 compile)
|
|
(incf c3 gc)
|
|
(incf c4 process)
|
|
(incf c5 net)))
|
|
(format f "~11d~12d~10d~12d~12d TOTAL~%"
|
|
c1 c2 c3 c4 c5)))))
|
|
|
|
(defun parallel-execute-tests (files &optional (max-jobs *njobs*))
|
|
(format t "Using ~D processes~%" max-jobs)
|
|
(let* ((subprocess-count 0)
|
|
(subprocess-list nil)
|
|
;; Start timing only after all the DIRECTORY calls are done (above)
|
|
(start-time (get-internal-real-time))
|
|
(losing)
|
|
(metricsfilename (format nil "~A/performance" *logdir*))
|
|
(metricsfile
|
|
(sb-unix:unix-open (namestring (make-pathname :type "lisp-expr"
|
|
:defaults metricsfilename))
|
|
(logior sb-unix:o_creat sb-unix:o_wronly sb-unix:o_append)
|
|
#o666)))
|
|
(labels ((wait ()
|
|
;; Though far from elegant, this is an easy way to figure out
|
|
;; which tests are getting stuck, if any are.
|
|
#+nil (format t "Runner is waiting on: ~S~%" subprocess-list)
|
|
(multiple-value-bind (pid status) (sb-posix:wait)
|
|
(decf subprocess-count)
|
|
(let ((process (assoc pid subprocess-list))
|
|
(code (ash status -8))
|
|
(et))
|
|
(unless process
|
|
(warn "Whoa! Process ~D is an unexpected child" pid)
|
|
(return-from wait (wait)))
|
|
(setq subprocess-list (delete process subprocess-list))
|
|
(destructuring-bind ((filename . iteration) start-time) (cdr process)
|
|
(setq et (elapsed-time-from start-time))
|
|
(cond ((eq code 104)
|
|
(format t "~A: success (~d µsec)~%" filename et))
|
|
(t
|
|
(format t "~A~@[[~d]~]: status ~D (~d µsec)~%"
|
|
filename iteration code et)
|
|
(push (list filename iteration pid) losing)))))))
|
|
(elapsed-time-from (when) ; return value in microseconds
|
|
(round (- (get-internal-real-time) when)
|
|
(/ internal-time-units-per-second 1000000))))
|
|
(dolist (file files)
|
|
(when (>= subprocess-count max-jobs)
|
|
(wait))
|
|
(let ((pid (sb-posix:fork)))
|
|
(when (zerop pid)
|
|
;; FILE is (filename . test-iteration)
|
|
(with-open-file (stream (format nil "~A/~a~@[-~d~]"
|
|
*logdir* (car file) (cdr file))
|
|
:direction :output :if-exists :supersede)
|
|
(alien-funcall (extern-alien "dup2" (function int int int))
|
|
(sb-sys:fd-stream-fd stream) 1)
|
|
(alien-funcall (extern-alien "dup2" (function int int int)) 1 2))
|
|
(setq file (car file))
|
|
;; Send this to the log file, not the terminal
|
|
(setq *debug-io* (make-two-way-stream (make-concatenated-stream)
|
|
*error-output*))
|
|
(let ((*features* (cons :parallel-test-runner *features*))
|
|
(run-time-start (get-internal-run-time)))
|
|
(pure-runner (list (concatenate 'string file ".lisp"))
|
|
(if (search "-cload" file) 'cload-test 'load-test)
|
|
(make-broadcast-stream))
|
|
(output-metrics sb-c::*compile-file-elapsed-time*
|
|
sb-c::*compile-elapsed-time*
|
|
*gc-run-time*
|
|
(- (get-internal-run-time) run-time-start)
|
|
file
|
|
(if (unexpected-failures) :fail :pass)
|
|
metricsfile)
|
|
(exit :code (if (unexpected-failures) 1 104))))
|
|
(format t "~A: pid ~d~@[ (trial ~d)~]~%" (car file) pid (cdr file))
|
|
(incf subprocess-count)
|
|
(push (list pid file (get-internal-real-time)) subprocess-list)))
|
|
(loop (if (plusp subprocess-count) (wait) (return)))
|
|
(format t "~&Total realtime: ~,,-6f sec~%" (elapsed-time-from start-time))
|
|
(sb-unix:unix-close metricsfile)
|
|
(sort-metrics metricsfilename)
|
|
(when losing
|
|
(format t "~&Failing files:~%")
|
|
(dolist (filename losing)
|
|
(format t "~A~%" filename))
|
|
(format t "==== Logs are in ~A ====~%" *logdir*)
|
|
(exit :code 1)))))
|
|
|
|
(parallel-execute-tests
|
|
(mapcar #'list
|
|
(choose-order
|
|
(mapcar #'pathname-name
|
|
(append (pure-load-files)
|
|
(pure-cload-files)
|
|
(impure-load-files)
|
|
(impure-cload-files))))))
|