>From fbc75dc62ccdb39d0b87117a60d069231d1acc58 Mon Sep 17 00:00:00 2001 From: Pietro Cerutti Date: Mon, 13 Nov 2023 15:22:40 +0000 Subject: [PATCH] chicken-install: support building/installing eggs in parallel This adds the -j / -max-procs command line argument to chicken-install. The work scheduler implementation is identical to the one I contributed for the csm egg [1]. I have tried to keep the diffs to the (install-eggs) function to a minimum and I avoided reindenting the whole thing, at the cost of a clumsy "make-egg" definition at the top of the function. I can do it prettier and produce a larger diff due to whitespace. As you guys prefer. As a smoke test, I measured the time it takes to install srfi-19 from a clean environment with no eggs installed and an empty cache with -j 1 (the default) and -j 4. Time goes down from 5m30.00s to 4m21.98s. Reasonably good. [1] http://bugs.call-cc.org/changeset/42311/project --- chicken-install.scm | 94 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 86 insertions(+), 8 deletions(-) diff --git a/chicken-install.scm b/chicken-install.scm index 56c741db..2d578cad 100644 --- a/chicken-install.scm +++ b/chicken-install.scm @@ -97,6 +97,7 @@ (define keepfiles #f) (define print-repository #f) (define cached-only #f) +(define max-procs 1) (define platform (if (eq? (software-version) 'mingw32) 'windows 'unix)) @@ -857,11 +858,79 @@ (loop2 (cdr srvs)))))) (loop1 (cdr eggs))))))) +(define (to-levels tree topo) + (define (depends-on? elem level) + (any (lambda (lvl) + (let ((adj-list-of-a (assoc elem tree))) + (and adj-list-of-a (member lvl adj-list-of-a)))) + level)) + (let loop ((topo (reverse topo)) (levs '())) + (if (null? topo) + levs + (if (and (pair? topo) (null? levs)) + (let ((curr (car topo)) + (next (cdr topo))) + (loop next (list (list curr)))) + (if (and (pair? topo) (pair? levs)) + (let ((curr (car topo)) + (next (cdr topo)) + (x (car levs)) + (y (cdr levs))) + (let lvl-loop ((seen-lvl '()) + (cand-lvl '()) + (curr-lvl x) + (next-lvl y)) + (if (depends-on? curr curr-lvl) + (loop next + (append seen-lvl + (cons (cons curr cand-lvl) + (cons curr-lvl next-lvl)))) + (if (null? next-lvl) + (loop next + (append seen-lvl + (list cand-lvl) + (list (cons curr curr-lvl)))) + + (lvl-loop + (append seen-lvl (if (null? cand-lvl) '() (list cand-lvl))) + curr-lvl + (car next-lvl) + (cdr next-lvl))))))))))) + +(cond-expand + (windows + (define (bfork p) (p)) + (define (bjoin _) (values #f #f 0))) + (else + (define bfork process-fork) + (define bjoin process-wait))) + +(define (spawn levels fun) + (define (make-level lvl) + (if (eq? 1 max-procs) + (for-each fun lvl) + (let ((n (length lvl))) + (if (eq? n 1) + (fun (car lvl)) + (let ((slots (min n max-procs))) + (let loop ((idx 0) (chunk lvl) (pids '())) + (if (or (null? chunk) (eq? idx slots)) + (begin + (for-each + (lambda (x) + (let-values (((pid succ rc) (bjoin x))) + (unless (eq? 0 rc) (exit 1)) + succ)) + pids) + (unless (null? chunk) (loop 0 chunk '()))) + (let ((pid (bfork (lambda () (fun (car chunk)))))) + (loop (+ 1 idx) (cdr chunk) (cons pid pids)))))))))) + (for-each make-level levels)) ;; perform installation of retrieved eggs (define (install-eggs) - (for-each + (define make-egg (lambda (egg) (let* ((name (car egg)) (dir (cadr egg)) @@ -928,16 +997,18 @@ (run-script dir bscript platform) (unless (if (member name requested-eggs) no-install no-install-dependencies) (print "installing " name " (target)") - (run-script dir iscript platform))))))))) - (order-installed-eggs))) + (run-script dir iscript platform)))))))))) -(define (order-installed-eggs) - (let* ((dag (reverse (sort-dependencies dependencies string=?))) - (ordered (filter-map (cut assoc <> canonical-eggs) dag))) + (let* ((dag (sort-dependencies dependencies string=?)) + (lvl (reverse (to-levels dependencies dag)))) (unless quiet (d "install order:~%") - (pp dag)) - ordered)) + (pp lvl)) + (spawn + lvl + (lambda (egg-name) + (let ((egg (assoc egg-name canonical-eggs))) + (when egg (make-egg egg))))))) (define (test-egg egg platform) (let* ((name (car egg)) @@ -1092,6 +1163,7 @@ usage: chicken-install [OPTION ...] [NAME[:VERSION] ...] -force don't ask, install even if versions don't match -k -keep keep temporary files -s -sudo use external command to elevate privileges for filesystem operations + -j -max-procs NUM use NUM processes in parallel for building -l -location DIRECTORY get egg sources from DIRECTORY. May be provided multiple times. Locations specified on the command line have precedence over the ones specified in setup.defaults. @@ -1201,6 +1273,12 @@ EOF ((member arg '("-n" "-no-install")) (set! no-install #t) (loop (cdr args))) + ((member arg '("-j" "-max-procs")) + (when (null? (cdr args)) + (fprintf (current-error-port) "-j|-max-procs: missing argument.~%") + (exit 1)) + (set! max-procs (string->number (cadr args))) + (loop (cddr args))) ((equal? arg "-purge") (set! purge-mode #t) (loop (cdr args))) -- 2.42.0