From f87aefc997080a9e1178bb64f5103a1d90849857 Mon Sep 17 00:00:00 2001 From: Orivej Desh Date: Sat, 31 Aug 2013 20:11:50 +0000 Subject: [PATCH 1/4] Add source-host generic function to determine source location host. --- upstream-bzr.lisp | 7 ++++++- upstream-cvs.lisp | 6 ++++++ upstream.lisp | 4 ++++ 3 files changed, 16 insertions(+), 1 deletion(-) diff --git a/upstream-bzr.lisp b/upstream-bzr.lisp index 312ff80..1bdea4b 100644 --- a/upstream-bzr.lisp +++ b/upstream-bzr.lisp @@ -9,10 +9,15 @@ :checkout-subcommand "branch" :update-subcommand "merge")) +(defmethod source-host :around ((source bzr-source)) + (if (string= "lp:" (location source) :end2 3) + "launchpad.net" + (call-next-method))) + (defmethod make-release-tarball ((source bzr-source) output-file) (let* ((prefix (release-tarball-prefix source)) (tar-name (string-right-trim "/" prefix)) - (checkout (ensure-source-cache source))) + (checkout (ensure-source-cache source))) (in-temporary-directory prefix (let ((tempgz (make-pathname :name tar-name :type "tgz"))) (with-posix-cwd checkout diff --git a/upstream-cvs.lisp b/upstream-cvs.lisp index 35b8c41..1419793 100644 --- a/upstream-cvs.lisp +++ b/upstream-cvs.lisp @@ -18,6 +18,12 @@ (defmethod source-location-initargs ((source cvs-oddmodule-source)) (list :location :module-name)) +(defmethod source-host ((source cvs-source)) + (let* ((location (location source)) + (host-start (1+ (position #\@ location))) + (host-end (position #\: location :start host-start))) + (subseq location host-start host-end))) + (defmethod source-description ((source cvs-source)) (format nil "cvs -d ~A co ~A" (location source) diff --git a/upstream.lisp b/upstream.lisp index 90e2f70..3d9bf82 100644 --- a/upstream.lisp +++ b/upstream.lisp @@ -83,6 +83,10 @@ (:method (source) (list :location))) +(defgeneric source-host (source) + (:method (source) + (puri:uri-host (puri:parse-uri (location source))))) + (defgeneric parse-location (source location-string) (:documentation "Update an instance by parsing its location value.") (:method (source location-string) From 2f289fa394acbaf14a9decf71d002209091bf4fd Mon Sep 17 00:00:00 2001 From: Orivej Desh Date: Sat, 31 Aug 2013 21:13:51 +0000 Subject: [PATCH 2/4] Proof-of-concept parallelized fetching. --- misc.lisp | 12 ++++++------ quicklisp-controller.asd | 3 ++- upstream.lisp | 18 ++++++++++++++++++ 3 files changed, 26 insertions(+), 7 deletions(-) diff --git a/misc.lisp b/misc.lisp index 186c82b..f1f8a69 100644 --- a/misc.lisp +++ b/misc.lisp @@ -177,12 +177,12 @@ (flet ((action (stream) (call-with-skipping (lambda () - (map-sources (lambda (source) - (force-output stream) - (format t "~&Updating ~S from ~A~%" - (project-name source) - (location source)) - (update-source-cache source)))) + (pmap-sources (lambda (source) + (force-output stream) + (format t "~&Updating ~S from ~A~%" + (project-name source) + (location source)) + (update-source-cache source)))) :stream stream))) (if file (with-open-file (stream file :direction :output diff --git a/quicklisp-controller.asd b/quicklisp-controller.asd index 8660713..afc331e 100644 --- a/quicklisp-controller.asd +++ b/quicklisp-controller.asd @@ -10,7 +10,8 @@ #:cl-ppcre #:alexandria #:drakma - #:ironclad) + #:ironclad + #:lparallel) :serial t :components ((:file "tarhash") (:file "package") diff --git a/upstream.lisp b/upstream.lisp index 3d9bf82..57de7f9 100644 --- a/upstream.lisp +++ b/upstream.lisp @@ -130,6 +130,24 @@ (with-simple-restart (skip "Skip ~A source" project-name) (funcall fun (load-source-file project-name source-file))))))) +(defun pmap-sources (fun) + (let ((dependency-tree (lparallel:make-ptree)) + (host-dependency (make-hash-table :test 'equal)) + (i 0)) + (map-sources (lambda (source) + (let ((host (source-host source))) + (lparallel:ptree-fn i (gethash host host-dependency) + (lambda (&optional arg) + (declare (ignore arg)) + (funcall fun source)) + dependency-tree) + (setf (gethash host host-dependency) (list i)) + (incf i)))) + (lparallel:ptree-fn 'everything (loop for j below i collect j) + (constantly nil) dependency-tree) + (lparallel:call-ptree 'everything dependency-tree) + nil)) + (defun find-source (name) (block nil (map-sources (lambda (source) From 902ef267cfa02ff547f5d45210424e7707bbf2f3 Mon Sep 17 00:00:00 2001 From: Orivej Desh Date: Sat, 31 Aug 2013 22:32:36 +0000 Subject: [PATCH 3/4] Make SKIP restart available in pmap-sources. --- upstream.lisp | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/upstream.lisp b/upstream.lisp index 57de7f9..aa8ffdd 100644 --- a/upstream.lisp +++ b/upstream.lisp @@ -121,14 +121,17 @@ (defvar *current-mapped-source* nil) +(defun map-source (fun source) + (let ((*current-mapped-source* (project-name source-file))) + (with-simple-restart (skip "Skip ~A source" *current-mapped-source*) + (funcall fun source)))) + (defun map-sources (fun) (with-simple-restart (abort "Give up entirely") (dolist (source-file (directory #p"quicklisp-controller:projects;**;source.txt")) - (let* ((project-name (pathname-project-name source-file)) - (*current-mapped-source* project-name)) - (with-simple-restart (skip "Skip ~A source" project-name) - (funcall fun (load-source-file project-name source-file))))))) + (let ((project-name (pathname-project-name source-file))) + (map-source fun (load-source-file project-name source-file)))))) (defun pmap-sources (fun) (let ((dependency-tree (lparallel:make-ptree)) @@ -137,10 +140,10 @@ (map-sources (lambda (source) (let ((host (source-host source))) (lparallel:ptree-fn i (gethash host host-dependency) - (lambda (&optional arg) - (declare (ignore arg)) - (funcall fun source)) - dependency-tree) + (lambda (&optional arg) + (declare (ignore arg)) + (map-source fun source)) + dependency-tree) (setf (gethash host host-dependency) (list i)) (incf i)))) (lparallel:ptree-fn 'everything (loop for j below i collect j) From 3b77c5779211d112dbdea64beabd8ee4735e20d5 Mon Sep 17 00:00:00 2001 From: Orivej Desh Date: Sat, 31 Aug 2013 23:16:03 +0000 Subject: [PATCH 4/4] Make parallel update-what-you-can intercept all errors. --- misc.lisp | 50 ++++++++++++++++++++++++++++++-------------------- upstream.lisp | 2 +- 2 files changed, 31 insertions(+), 21 deletions(-) diff --git a/misc.lisp b/misc.lisp index f1f8a69..79d50c2 100644 --- a/misc.lisp +++ b/misc.lisp @@ -162,31 +162,41 @@ (intern (string-upcase project)))) -(defun call-with-skipping (fun &key (stream *standard-output*)) - (handler-bind ((error (lambda (condition) - (when (find-restart 'skip) - (when (boundp '*current-mapped-source*) - (format stream "~&* ~A~%" *current-mapped-source*) - (format stream ":: from ~A~%" - (find-source *current-mapped-source*))) - (format stream "~&SKIPPING (~A)~%" condition) - (invoke-restart 'skip))))) - (funcall fun))) - -(defun update-what-you-can (&optional file) +(defvar *output-lock* (bt:make-lock "output-lock")) + +(defun call-with-skipping (fun &key (stream *standard-output*) parallel) + (flet ((invoke-skip (condition) + (when (find-restart 'skip) + (bt:with-lock-held (*output-lock*) + (when (boundp '*current-mapped-source*) + (format stream "~&* ~A~%" *current-mapped-source*) + (format stream ":: from ~A~%" + (find-source *current-mapped-source*))) + (format stream "~&SKIPPING (~A)~%" condition)) + (invoke-restart 'skip)))) + (if (not parallel) + (handler-bind ((error #'invoke-skip)) + (funcall fun)) + (lparallel:task-handler-bind ((error #'invoke-skip)) + (funcall fun))))) + +(defun update-what-you-can (&optional file parallel) (flet ((action (stream) (call-with-skipping (lambda () - (pmap-sources (lambda (source) - (force-output stream) - (format t "~&Updating ~S from ~A~%" - (project-name source) - (location source)) - (update-source-cache source)))) - :stream stream))) + (funcall (if parallel 'pmap-sources 'map-sources) + (lambda (source) + (bt:with-lock-held (*output-lock*) + (force-output stream) + (format t "~&Updating ~S from ~A~%" + (project-name source) + (location source))) + (update-source-cache source)))) + :stream stream + :parallel parallel))) (if file (with-open-file (stream file :direction :output - :if-exists :rename-and-delete) + :if-exists :rename-and-delete) (action (make-broadcast-stream *standard-output* stream))) (action *standard-output*)))) diff --git a/upstream.lisp b/upstream.lisp index aa8ffdd..27c8aea 100644 --- a/upstream.lisp +++ b/upstream.lisp @@ -122,7 +122,7 @@ (defvar *current-mapped-source* nil) (defun map-source (fun source) - (let ((*current-mapped-source* (project-name source-file))) + (let ((*current-mapped-source* (project-name source))) (with-simple-restart (skip "Skip ~A source" *current-mapped-source*) (funcall fun source))))