tjh.dev
1#!/usr/bin/env -S sbcl --script
2
3(require :uiop)
4
5;; prevent glibc hell
6(setf (uiop:getenv "LD_LIBRARY_PATH") "")
7
8(defparameter packages (uiop:read-file-lines "./lispPackagesToTest.txt"))
9
10(defparameter lisp (or (cadr sb-ext:*posix-argv*) "sbcl"))
11
12(defparameter nix-build "nix-build -E 'with import ../../../../default.nix {}; lispPackages_new.~aPackages.~a'")
13
14(defparameter cpu-count
15 (length
16 (remove-if-not
17 (lambda (line)
18 (uiop:string-prefix-p "processor" line))
19 (uiop:read-file-lines "/proc/cpuinfo"))))
20
21(defparameter sem (sb-thread:make-semaphore :count cpu-count))
22
23(defparameter statuses (make-hash-table :synchronized t))
24
25(defparameter log-lock (sb-thread:make-mutex))
26
27(format *error-output* "Testing ~a on ~a cores~%" lisp cpu-count)
28
29(defun clear-line ()
30 (write-char #\Return *error-output*)
31 (write-char #\Escape *error-output*)
32 (write-char #\[ *error-output*)
33 (write-char #\K *error-output*))
34
35(declaim (type fixnum errors))
36(defglobal errors 0)
37
38(defmacro when-let (bindings &rest body)
39 (reduce
40 (lambda (expansion form)
41 (destructuring-bind (var test) form
42 (let ((testsym (gensym (symbol-name var))))
43 `(let ((,testsym ,test))
44 (when ,testsym
45 (let ((,var ,testsym))
46 ,expansion))))))
47 (reverse bindings)
48 :initial-value `(progn ,@body)))
49
50(dolist (pkg packages)
51 (sb-thread:wait-on-semaphore sem)
52 (sb-thread:make-thread
53 (lambda ()
54 (handler-case
55 (unwind-protect
56 (multiple-value-bind (out err code)
57 (uiop:run-program
58 (format nil nix-build lisp pkg)
59 :error-output '(:string :stripped t)
60 :ignore-error-status t)
61 (declare (ignorable err))
62 (setf (gethash pkg statuses) code)
63 (when-let ((pos (search "LOAD-FOREIGN-LIBRARY-ERROR" err :test #'string=))
64 (lines (uiop:split-string (subseq err pos) :separator '(#\Newline))))
65 (setf (gethash pkg statuses)
66 (fourth lines)))
67 (sb-thread:with-mutex (log-lock)
68 (clear-line)
69 (format *error-output* "[~a/~a] ~[OK~:;ERROR~] ~a~[~:;~%~]"
70 (hash-table-count statuses)
71 (length packages)
72 code
73 pkg
74 code)
75 (force-output *error-output*))
76 (unless (zerop code)
77 (sb-ext:atomic-incf errors)))
78 (sb-thread:signal-semaphore sem))
79 (error (e)
80 (format t "~a~%" e)
81 (sb-ext:quit :recklessly-p t :unix-status 1))))))
82
83(sb-thread:wait-on-semaphore sem :n cpu-count)
84
85(format t "~%Done (~a/~a)."
86 (- (length packages) errors)
87 (length packages))
88
89(when (plusp errors)
90 (format t "~%~%~a Errors: " errors)
91 (maphash (lambda (k v)
92 (unless (and (numberp v) (zerop v))
93 (format t "~% ~a: ~a" k v)))
94 statuses))