From 2417bec0e7bdd64e1a59e1d3dbb6960256274440 Mon Sep 17 00:00:00 2001 From: Zachary Beane Date: Thu, 11 Jul 2019 12:52:18 -0400 Subject: [PATCH 1/5] Use keyword/value command-line arguments for depcheck This is to make it easier to add more options without dealing with positional argument issues. --- depcheck.lisp | 70 +++++++++++++++++++++++++++++++++---------------- dist-cache.lisp | 21 ++++++++++----- 2 files changed, 63 insertions(+), 28 deletions(-) diff --git a/depcheck.lisp b/depcheck.lisp index 74c29f4..f2a5d0d 100644 --- a/depcheck.lisp +++ b/depcheck.lisp @@ -111,8 +111,7 @@ (asdf:component-name system)))) (when (and (stringp value) (zerop (length value))))))) (check-attribute 'asdf:system-description :description) - ;; Not yet - ;;(check-attribute 'asdf:system-license :license) + (check-attribute 'asdf:system-license :license) (check-attribute 'asdf:system-author :author)))) (defun compute-dependencies (system-file system-name) @@ -190,27 +189,54 @@ (sb-alien:alien-funcall (sb-alien:extern-alien "disable_lossage_handler" (function sb-alien:void))) (setf *print-pretty* nil) - (when (equalp (second argv) "--asdf-version") - (format t "~A~%" (asdf:asdf-version)) - (sb-ext:exit :code 0)) - (when (equalp (second argv) "--sbcl-version") - (format t "~A~%" (lisp-implementation-version)) - (sb-ext:exit :code 0)) - (unless (getenv "DEPCHECK_DEBUG") - (sb-ext:disable-debugger)) - (setenv "SBCL_HOME" - (load-time-value - (directory-namestring sb-int::*core-string*))) - #+nil - (setenv "CC" "gcc") - (eval *load-op-wrapper*) - (when (getenv "DEPCHECK_FRESH_FASLS") - (set-fasl-output-directory (pathname (format nil "/tmp/depcheck/~D/" - (getpid))))) - (destructuring-bind (index project system dependency-file errors-file - &optional *metadata-required-p*) - (rest argv) + (sb-ext:disable-debugger) + (let (index project system dependency-file errors-file + (args (rest argv))) + (macrolet ((check-args (&rest vars) + `(progn + ,@(loop for var in vars + for flag = (format nil "--~A" + (string-downcase var)) + collect + `(unless ,var + (error "Missing option ~S" ,flag)))))) + (loop + (when (endp args) + (check-args index project system dependency-file errors-file) + (return)) + (let ((arg (pop args))) + (cond ((equal arg "--index") + (setf index (pop args))) + ((equal arg "--project") + (setf project (pop args))) + ((equal arg "--system") + (setf system (pop args))) + ((equal arg "--dependency-file") + (setf dependency-file (pop args))) + ((equal arg "--errors-file") + (setf errors-file (pop args))) + ;; Optional args follow + ((equal arg "--asdf-version") + (write-line (asdf:asdf-version)) + (sb-ext:exit :code 0)) + ((equal arg "--sbcl-version") + (write-line (lisp-implementation-version)) + (sb-ext:exit :code 0)) + ((equal arg "--debug") + (sb-ext:enable-debugger)) + ((equal arg "--metadata-required") + (setf *metadata-required-p* t)) + ((equal arg "--fasl-directory") + (let ((path (pop args))) + (ensure-directories-exist path) + (set-fasl-output-directory (truename path)))) + (t + (error "Unknown argument ~S" arg)))))) (setf *systems* (load-asdf-system-table index)) + (setenv "SBCL_HOME" + (load-time-value + (directory-namestring sb-int::*core-string*))) + (eval *load-op-wrapper*) (with-open-file (*error-output* errors-file :if-exists :supersede :direction :output) diff --git a/dist-cache.lisp b/dist-cache.lisp index 31ae5d4..5ed9284 100644 --- a/dist-cache.lisp +++ b/dist-cache.lisp @@ -252,17 +252,26 @@ if needed." "If true, a depcheck will fail if :author/:description/:license options are missing from a system.") -(defun depcheck (primary-system sub-system) +(defun depcheck (primary-system sub-system &key fasl-directory) (ensure-system-file-index) (ensure-in-anonymous-directory - (let ((win (temporary-pathname "depcheck-win.txt")) - (fail (temporary-pathname "depcheck-fail.txt"))) + (let* ((win (temporary-pathname "depcheck-win.txt")) + (fail (temporary-pathname "depcheck-fail.txt")) + (args (mapcan #'identity + (list + (list :index (native (translate-logical-pathname *system-file-index-file*))) + (list :project primary-system) + (list :system sub-system) + (list :dependency-file win) + (list :errors-file fail) + (when *system-metadata-required-p* + (list :metadata-required)) + (when fasl-directory + (list :fasl-directory fasl-directory)))))) (ignore-errors (delete-file win)) (ignore-errors (delete-file fail)) (ignore-errors - (run "depcheck" - (native (translate-logical-pathname *system-file-index-file*)) - primary-system sub-system win fail *system-metadata-required-p*)) + (apply #'run "depcheck" args)) (let* ((won (probe-file win)) (first-line (and won (ignore-errors (first-line-of win)))) (result (and first-line (split-spaces first-line)))) From 0d5a76793cfbdee4ace2ffed20b5f9f3bcda63e6 Mon Sep 17 00:00:00 2001 From: Zachary Beane Date: Thu, 11 Jul 2019 21:11:51 -0400 Subject: [PATCH 2/5] Make RUN smarter about converting raw args to final args This is to allow things like: (run "command" (when flagp "--flagp") (when foo (list "--foo" foo))) --- commands.lisp | 14 +++++++------- dist-cache.lisp | 31 ++++++++++++++++--------------- 2 files changed, 23 insertions(+), 22 deletions(-) diff --git a/commands.lisp b/commands.lisp index e8b110d..00a8a38 100644 --- a/commands.lisp +++ b/commands.lisp @@ -20,17 +20,17 @@ (run-error-command condition) (run-error-arguments condition))))) -(defun stringify-command-argument (argument) +(defun prepare-command-argument (argument) (typecase argument (null nil) - (string argument) - (pathname (native-namestring argument)) - (keyword (format nil "--~(~A~)" argument)) - (t (princ-to-string argument)))) + (list (mapcan #'prepare-command-argument argument)) + (string (list argument)) + (pathname (list (native-namestring argument))) + (keyword (list (format nil "--~(~A~)" argument))) + (t (list (princ-to-string argument))))) (defun run (command &rest arguments) - (let* ((arguments (remove nil - (mapcar #'stringify-command-argument arguments))) + (let* ((arguments (mapcan #'prepare-command-argument arguments)) (process (run-program command arguments :search t :wait t diff --git a/dist-cache.lisp b/dist-cache.lisp index 5ed9284..8a4e441 100644 --- a/dist-cache.lisp +++ b/dist-cache.lisp @@ -252,26 +252,27 @@ if needed." "If true, a depcheck will fail if :author/:description/:license options are missing from a system.") -(defun depcheck (primary-system sub-system &key fasl-directory) +(defvar *depcheck-fasl-output-directory* nil) + +(defun depcheck (primary-system sub-system + &key (fasl-directory *depcheck-fasl-output-directory*)) (ensure-system-file-index) (ensure-in-anonymous-directory - (let* ((win (temporary-pathname "depcheck-win.txt")) - (fail (temporary-pathname "depcheck-fail.txt")) - (args (mapcan #'identity - (list - (list :index (native (translate-logical-pathname *system-file-index-file*))) - (list :project primary-system) - (list :system sub-system) - (list :dependency-file win) - (list :errors-file fail) - (when *system-metadata-required-p* - (list :metadata-required)) - (when fasl-directory - (list :fasl-directory fasl-directory)))))) + (let ((win (temporary-pathname "depcheck-win.txt")) + (fail (temporary-pathname "depcheck-fail.txt"))) (ignore-errors (delete-file win)) (ignore-errors (delete-file fail)) (ignore-errors - (apply #'run "depcheck" args)) + (run "depcheck" + :index (native (translate-logical-pathname *system-file-index-file*)) + :project primary-system + :system sub-system + :dependency-file win + :errors-file fail + (when *system-metadata-required-p* + :metadata-required) + (when fasl-directory + (list :fasl-directory fasl-directory)))) (let* ((won (probe-file win)) (first-line (and won (ignore-errors (first-line-of win)))) (result (and first-line (split-spaces first-line)))) From 85a18d799dc7d303cc7290b507db8ce203119cd1 Mon Sep 17 00:00:00 2001 From: Zachary Beane Date: Thu, 11 Jul 2019 21:14:17 -0400 Subject: [PATCH 3/5] Use *DEFAULT-PATHNAME-DEFAULTS* as the :directory for sb-ext:run-program in RUN This is to maybe head off thread cwd problems. --- commands.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/commands.lisp b/commands.lisp index 00a8a38..02fc8b5 100644 --- a/commands.lisp +++ b/commands.lisp @@ -34,7 +34,8 @@ (process (run-program command arguments :search t :wait t - :output *command-output*))) + :output *command-output* + :directory *default-pathname-defaults*))) (unwind-protect (let ((code (process-exit-code process))) (if (zerop code) From fc950c1f0e1d512c2233aa13919639654a14c047 Mon Sep 17 00:00:00 2001 From: Zachary Beane Date: Thu, 11 Jul 2019 21:16:00 -0400 Subject: [PATCH 4/5] Try using PMAP-SOURCES everywhere. This bins sources into one of 16 buckets for parallelization purposes. --- dist-cache.lisp | 2 +- misc.lisp | 2 +- recrank.lisp | 2 +- upstream.lisp | 28 ++++++++++++++++++++++++---- 4 files changed, 27 insertions(+), 7 deletions(-) diff --git a/dist-cache.lisp b/dist-cache.lisp index 8a4e441..44741d5 100644 --- a/dist-cache.lisp +++ b/dist-cache.lisp @@ -187,7 +187,7 @@ if needed." (directory (merge-pathnames "contrib/*.asd" base)))) (dolist (file contrib-system-files) (setf (gethash (pathname-name file) table) file))) - (map-sources + (pmap-sources (lambda (source) (let ((base (ensure-cached-build-directory source)) (system-files (system-files source))) diff --git a/misc.lisp b/misc.lisp index 874424a..24dc550 100644 --- a/misc.lisp +++ b/misc.lisp @@ -232,7 +232,7 @@ (defun ensure-what-wins-you-can () (call-with-skipping (lambda () - (map-sources + (pmap-sources (lambda (source) (format t "~&Checking ~S~%" (project-name source)) ;;(clear-fasl-cache) diff --git a/recrank.lisp b/recrank.lisp index c37b064..90978ba 100644 --- a/recrank.lisp +++ b/recrank.lisp @@ -4,7 +4,7 @@ (defun recrank (&key (update t) (report t) (feeds t) (publish-failure-report t) - parallel + (parallel t) (file #p"quicklisp:tmp;update-failures.txt")) (clear-fasl-cache) (preflight) diff --git a/upstream.lisp b/upstream.lisp index c75a0a1..5fd9e00 100644 --- a/upstream.lisp +++ b/upstream.lisp @@ -150,11 +150,24 @@ (push source result)))) (sort result 'string< :key 'name))) -(defun pmap-sources (fun &key (parallel-key #'source-host) + +(defun source-bucket (source) + "Return a string suitable for binning a source for parallel work." + (subseq (string-digest (first-line-of (source-file source))) + 0 1)) + +(defun fasl-directory (source) + (translate-logical-pathname + (make-pathname :host "quicklisp-controller" + :directory (list :absolute "dist" "fasls" + (source-bucket source))))) + +(defun pmap-sources (fun &key (parallel-key 'source-bucket) (test #'identity)) (let ((dependency-tree (lparallel:make-ptree)) (parallel-key-dependency (make-hash-table :test 'equal)) - (i 0)) + (i 0) + (result '())) (map-sources (lambda (source) (let ((testp (funcall test source)) (pkey (funcall parallel-key source))) @@ -163,7 +176,14 @@ parallel-key-dependency) (lambda (&optional arg) (declare (ignore arg)) - (map-source fun source)) + (multiple-value-bind (result error) + (ignore-errors + (map-source fun source)) + (when error + (format *trace-output* "; ERROR: ~A -> ~%;; ~A~%" + source error) + (push (cons source error) + result)))) dependency-tree) (setf (gethash pkey parallel-key-dependency) (list i)) @@ -171,7 +191,7 @@ (lparallel:ptree-fn 'everything (loop for j below i collect j) (constantly nil) dependency-tree) (lparallel:call-ptree 'everything dependency-tree) - nil)) + (values nil result))) (defun project-name-source-file (project-name) (merge-pathnames From ef7c397e63906bfe5f9af4c71b9980ad751360e7 Mon Sep 17 00:00:00 2001 From: Zachary Beane Date: Thu, 11 Jul 2019 21:16:39 -0400 Subject: [PATCH 5/5] Clear the new location of the fasl cache properly --- dist-cache.lisp | 3 ++- misc.lisp | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/dist-cache.lisp b/dist-cache.lisp index 44741d5..c212624 100644 --- a/dist-cache.lisp +++ b/dist-cache.lisp @@ -433,7 +433,8 @@ structure \(SYSTEM-FILE-NAME SYSTEM-NAME &REST DEPENDENCIES). " (probe-file cached-winfile)) (push (split-spaces (first-line-of cached-winfile)) winners) (multiple-value-bind (deps winfile failfile) - (depcheck system-name system) + (depcheck system-name system + :fasl-directory (fasl-directory source)) (declare (ignore winfile)) (cond (deps (ignore-errors (delete-file cached-failfile)) diff --git a/misc.lisp b/misc.lisp index 24dc550..f6b59c6 100644 --- a/misc.lisp +++ b/misc.lisp @@ -3,8 +3,8 @@ (in-package #:quicklisp-controller) (defun clear-fasl-cache () - (run "rm" "-rf" (merge-pathnames ".cache/common-lisp/" - (user-homedir-pathname)))) + (run "rm" "-rf" + (translate-logical-pathname "quicklisp-controller:dist;fasls;"))) (defun system-from-release (system-name dist) (let* ((dist (ql-dist:dist dist))