tests/parallel-exec.sh

   1 #!/bin/sh
   2
   3 logdir=${SBCL_PAREXEC_TMP:-$HOME}/sbcl-test-logs-$$
   4 echo ==== Writing logs to $logdir ====
   5 # FIXME: junkdir isn't getting removed
   6 junkdir=${SBCL_PAREXEC_TMP:-/tmp}/junk
   7 mkdir -p $junkdir $logdir
   8
   9 case `uname` in
  10     CYGWIN* | WindowsNT | MINGW* | MSYS*)
  11         if [ $# -ne 1 ]
  12         then
  13             echo $0: Need arg
  14             exit 1
  15         fi
  16         echo ";; Using -j$1"
  17         echo "LOGDIR=$logdir" >$logdir/Makefile
  18         ../run-sbcl.sh --script genmakefile.lisp >>$logdir/Makefile
  19         exec $GNUMAKE -k -j $1 -f $logdir/Makefile
  20         ;;
  21 esac
  22
  23 export TEST_DIRECTORY SBCL_HOME
  24 TEST_DIRECTORY=$junkdir SBCL_HOME=../obj/sbcl-home exec ../src/runtime/sbcl \
  25   --noinform --core ../output/sbcl.core \
  26   --no-userinit --no-sysinit --noprint --disable-debugger $* << EOF
  27 (pop *posix-argv*)
  28 (require :sb-posix)
  29 #-sparc (push :test-sprof *features*)
  30 #+test-sprof (require :sb-sprof)
  31
  32 ;; (push :tlsf-stress *features*)
  33 #+tlsf-stress
  34 (progn
  35  (setq sb-c:*compile-to-memory-space* :immobile)
  36  (with-alien ((tlsf-control system-area-pointer :extern)
  37               (tlsf-mem-start system-area-pointer :extern))
  38    (defun tlsf-checks ()
  39      (alien-funcall (extern-alien "tlsf_check" (function void system-area-pointer))
  40                     tlsf-control)
  41      (alien-funcall (extern-alien "tlsf_check_pool" (function void system-area-pointer))
  42                     tlsf-mem-start)
  43     (let ((msg #.(format nil "TLSF checks passed~%")))
  44        (sb-unix:unix-write 2 msg 0 (length msg))))
  45    (defun tlsf-dump ()
  46      (alien-funcall (extern-alien "tlsf_dump_pool"
  47        (function void system-area-pointer system-area-pointer c-string))
  48        tlsf-control tlsf-mem-start "/dev/stdout")))
  49   (compile 'tlsf-checks)
  50   (compile 'tlsf-dump)
  51   (push #'tlsf-checks sb-ext:*after-gc-hooks*))
  52
  53 (let ((*evaluator-mode* :compile))
  54   (with-compilation-unit () (load"run-tests")))
  55 #+(and x86-64 linux sb-thread)
  56   (unless (or (find :mark-region-gc sb-impl:+internal-features+)
  57               (find :gs-seg sb-impl:+internal-features+))
  58     (push :test-aprof *features*))
  59 (in-package run-tests)
  60 (import '(sb-alien:alien-funcall sb-alien:extern-alien
  61           sb-alien:int sb-alien:c-string sb-alien:unsigned))
  62 (setq *summarize-test-times* t)
  63 ;;; Ordered approximately in descending order by running time
  64 (defvar *timings* (with-open-file (s "timing") (read s)))
  65
  66 (defvar *filter* nil)
  67 (defglobal *delete-logs* nil)
  68 (defun choose-order (tests)
  69   (when *filter*
  70     (let (strings)
  71       (with-open-file (file *filter*)
  72         (loop (let ((line (read-line file nil)))
  73                 (if line (push line strings) (return)))))
  74       (setq tests (remove-if (lambda (x) (not (find x strings :test #'string=)))
  75                              tests))))
  76   (sort tests
  77         #'> :key (lambda (file) (or (cadr (assoc file *timings* :test #'equal)) 0))))
  78
  79 (defun summarize-gc-times ()
  80   ;; this function prints random numbers now, I don't know why
  81   (return-from summarize-gc-times)
  82   (let (observations)
  83     (flet ((parse-triple (string pos)
  84              (sb-int:binding* (((int1 end) (parse-integer string :start (1+ pos)
  85                                                                  :junk-allowed t))
  86                                ((int2 end) (parse-integer string :start (1+ end)
  87                                                                  :junk-allowed t))
  88                                ((int3) (parse-integer string :start (1+ end)
  89                                                              :junk-allowed t)))
  90                (list int1 int2 int3))))
  91       (dolist (pn (directory "$logdir/*.*"))
  92         (with-open-file (f pn)
  93           (let ((legend "GC: stw_delay"))
  94             (loop
  95              (let ((line (read-line f nil)))
  96                (unless line (return))
  97                (when (and (> (length line) (length legend))
  98                           (string= line legend :end1 (length legend)))
  99                  (let* ((p1 (position #\= line))
 100                         (p2 (position #\= line :start (1+ p1)))
 101                         (stw-dur (parse-triple line p1))
 102                         (gc-dur (parse-triple line p2))
 103                         (count (parse-integer line :start (+ (search "over " line) 5)
 104                                               :junk-allowed t)))
 105                    (let ((name (concatenate 'string (pathname-name pn) "."
 106                                             (pathname-type pn))))
 107                      (push (list count stw-dur gc-dur name) observations))))))))))
 108     (let ((fmt "  ~5d (~{~10d~^ ~}) (~{~7d~^ ~}) ~a~%"))
 109       (format t "~&Top 15 worst by max time to stop-the-world:~%")
 110       (let ((list (sort (copy-list observations) #'> :key (lambda (x) (third (second x))))))
 111         (dotimes (i 15) (apply #'format t fmt (pop list))))
 112       (format t "~&Top 15 worst by avg GC duration (excluding STW delay):~%")
 113       (let ((list (sort (copy-list observations) #'> :key (lambda (x) (second (third x))))))
 114         (dotimes (i 15) (apply #'format t fmt (pop list))))
 115       (format t "~&Top 15 worst by max GC duration (excluding STW delay):~%")
 116       (let ((list (sort (copy-list observations) #'> :key (lambda (x) (third (third x))))))
 117         (dotimes (i 15) (apply #'format t fmt (pop list)))))))
 118 (defun parallel-execute-tests (files max-jobs vop-summary-stats-p)
 119   (format t "Using ~D processes~%" max-jobs)
 120   ;; Interleave the order in which all tests are launched rather than
 121   ;; starting them in the batches that filtering places them in.
 122   (let ((subprocess-count 0)
 123         (subprocess-list nil)
 124         (aggregate-vop-usage (make-hash-table :test #'equal))
 125         ;; Start timing only after all the DIRECTORY calls are done (above)
 126         (start-time (get-internal-real-time))
 127         (missing-usage)
 128         (losing))
 129     (labels ((wait ()
 130                ;; Though far from elegant, this is an easy way to figure out
 131                ;; which tests are getting stuck, if any are.
 132                #+nil (format t "Runner is waiting on: ~S~%" subprocess-list)
 133                (multiple-value-bind (pid status) (sb-posix:wait)
 134                  (decf subprocess-count)
 135                  (let ((process (assoc pid subprocess-list))
 136                        (code (ash status -8))
 137                        (et))
 138                    (unless process
 139                      (warn "Whoa! Process ~D is an unexpected child" pid)
 140                      (return-from wait (wait)))
 141                    (setq subprocess-list (delete process subprocess-list))
 142                    (destructuring-bind ((filename . iteration) start-time) (cdr process)
 143                      (setq et (elapsed-time-from start-time))
 144                      (when vop-summary-stats-p
 145                        (unless (sum-vop-usage (format nil "$logdir/~a.vop-usage" filename) t)
 146                          (when (or (search ".pure" filename) (search ".impure" filename))
 147                            (push filename missing-usage))))
 148                      (cond ((eq code 104)
 149                             (format t "~A: success (~d msec)~%" filename et))
 150                            (t
 151                             (format t "~A~@[[~d]~]: status ~D (~d msec)~%"
 152                                       filename iteration code et)
 153                             (push (list filename iteration pid) losing)))))))
 154              (elapsed-time-from (when) ; return value in milliseconds
 155                (round (- (get-internal-real-time) when)
 156                       (/ internal-time-units-per-second 1000)))
 157              (sum-vop-usage (input deletep)
 158                (with-open-file (f input :if-does-not-exist nil)
 159                  ;; No vop coverage file from shell script tests or any test
 160                  ;; that internally uses (EXIT) for whatever reason.
 161                  (when f
 162                    (loop (let ((line (read-line f nil)))
 163                            (unless line (return))
 164                            (let ((count (read-from-string line))
 165                                  (name (read-from-string line t nil :start 8)))
 166                              (incf (gethash name aggregate-vop-usage 0) count))))
 167                    (when deletep (delete-file f))))))
 168       (dolist (file files)
 169         (when (>= subprocess-count max-jobs)
 170           (wait))
 171         (let ((pid (sb-posix:fork)))
 172           (when (zerop pid)
 173           (let  ((mylog (format nil "$logdir/~a~@[-~d~]" (car file) (cdr file))))
 174             ;; FILE is (filename . test-iteration)
 175             (with-open-file (stream mylog :direction :output :if-exists :supersede)
 176               (alien-funcall (extern-alien "dup2" (function int int int))
 177                              (sb-sys:fd-stream-fd stream) 1)
 178               (alien-funcall (extern-alien "dup2" (function int int int)) 1 2))
 179             (setq file (car file))
 180             #+test-aprof
 181             (unless (search "allocator.pure" file)
 182               (sb-aprof::aprof-start)
 183               (proclaim '(optimize sb-c:instrument-consing)))
 184             ;; Send this to the log file, not the terminal
 185             (setq *debug-io* (make-two-way-stream (make-concatenated-stream)
 186                                                   *error-output*))
 187             (cond ((string= (pathname-type file) "test")
 188                    (let ((shell (or #+sunos (posix-getenv "SHELL") "/bin/sh")))
 189                      ;; exec the shell with the test and we'll pick up its exit code
 190                      (alien-funcall (extern-alien "execl" (function int c-string c-string
 191                                                                     &optional c-string unsigned))
 192                                     shell shell
 193                                     (concatenate 'string file ".sh") 0))
 194                    ;; if exec fails, just exit with a wrong (not 104) status
 195                    (alien-funcall (extern-alien "_exit" (function (values) int)) 0))
 196                   (t
 197                    #+test-sprof (sb-sprof:start-profiling :sample-interval .001)
 198                    (setq sb-c::*static-vop-usage-counts* (make-hash-table :synchronized t))
 199                    (let ((*features* (cons :parallel-test-runner *features*)))
 200                      (pure-runner (list (concatenate 'string file ".lisp"))
 201                                   (if (search "-cload" file) 'cload-test 'load-test)
 202                                   (make-broadcast-stream)))
 203                    (when vop-summary-stats-p
 204                      (with-open-file (output (format nil "$logdir/~a.vop-usage" file)
 205                                              :direction :output)
 206                        ;; There's an impure test that screws with the default pprint dispatch
 207                        ;; table such that integers don't print normally (and can't be parsed).
 208                        (let ((*print-pretty* nil))
 209                          (sb-int:dohash ((name count) sb-c::*static-vop-usage-counts*)
 210                            (format output "~7d \"~s\"~%" count name)))))
 211                    #+test-sprof (sb-sprof:stop-profiling)
 212                    #+test-aprof (progn (sb-aprof::aprof-stop) (sb-aprof:aprof-show))
 213                    (when (member :allocator-metrics sb-impl:+internal-features+)
 214                      (format t "~2&Allocator histogram:~%")
 215                      (funcall (intern "PRINT-ALLOCATOR-HISTOGRAM" "SB-THREAD")))
 216                    #+test-sprof (sb-sprof:report :type :flat)
 217                    #+tlsf-stress (cl-user::tlsf-dump)
 218                    (gc :gen 7)
 219                    (when (and (not (unexpected-failures)) *delete-logs*) (delete-file mylog))
 220                    (exit :code (if (unexpected-failures) 1 104))))))
 221           (format t "~A: pid ~d~@[ (trial ~d)~]~%" (car file) pid (cdr file))
 222           (incf subprocess-count)
 223           (push (list pid file (get-internal-real-time)) subprocess-list)))
 224       (loop (if (plusp subprocess-count) (wait) (return)))
 225
 226       (when vop-summary-stats-p
 227         (dolist (result '("vop-usage.txt" "vop-usage-combined.txt"))
 228           (let (list)
 229             (sb-int:dohash ((name vop) sb-c::*backend-template-names*)
 230               (declare (ignore vop))
 231               (push (cons (gethash (prin1-to-string name) aggregate-vop-usage 0) name) list))
 232             (with-open-file (output (format nil "$logdir/~a" result)
 233                                             :direction :output
 234                                             :if-exists :supersede)
 235               (dolist (cell (sort list #'> :key #'car))
 236                 (format output "~7d ~s~%" (car cell) (cdr cell)))))
 237           (sum-vop-usage "../obj/from-self/warm-vop-usage.txt" nil)))
 238
 239       (format t "~&Total realtime: ~d msec~%" (elapsed-time-from start-time))
 240       (when missing-usage
 241         (format t "~&Missing vop-usage:~{ ~a~}~%" missing-usage))
 242
 243       (when losing
 244         (format t "~&Failing files:~%")
 245         (dolist (filename losing)
 246           (format t "~A~%" filename))
 247         (format t "==== Logs are in $logdir ====~%")
 248         (exit :code 1)))))
 249 (when (string= (car *posix-argv*) "--filter")
 250   (setq *filter* (cadr *posix-argv*))
 251   (setq *posix-argv* (cddr *posix-argv*)))
 252 (if (= (length *posix-argv*) 1)
 253     ;; short form - all files, argument N is the number of parallel tasks
 254     (let ((jobs (parse-integer (car *posix-argv*))))
 255       (parallel-execute-tests
 256        (mapcar #'list
 257                (choose-order
 258                 (mapcar #'pathname-name
 259                         (append (pure-load-files)
 260                                 (pure-cload-files)
 261                                 (impure-load-files)
 262                                 (impure-cload-files)
 263                                 (sh-files)))))
 264        jobs
 265        t)
 266       #+(and linux sb-thread 64-bit) (summarize-gc-times))
 267     ;; long form
 268     (let ((jobs 4)
 269           (runs-per-test 1)
 270           (argv *posix-argv*))
 271       (loop (cond ((string= (car argv) "-j")
 272                    (setq jobs (parse-integer (cadr argv))
 273                          argv (cddr argv)))
 274                   ((string= (car argv) "--runs_per_test")
 275                    (setq runs-per-test (parse-integer (cadr argv))
 276                          argv (cddr argv)))
 277                   (t
 278                    (return))))
 279       (when (>= runs-per-test 10)
 280         (format t "~&Note: will not keep logs of passing runs~%")
 281         (setq *delete-logs* t))
 282       (setq argv
 283         (mapcar (lambda (file)
 284                   (probe-file file) ; for effect
 285                   (pathname-name file)) argv))
 286       (parallel-execute-tests
 287        (loop for trial-number from 1 to runs-per-test
 288              nconc (mapcar (lambda (file)
 289                              (cons file
 290                                    (when (> runs-per-test 1) trial-number)))
 291                            argv))
 292        jobs
 293        nil)))
 294 EOF