From fbc75dc62ccdb39d0b87117a60d069231d1acc58 Mon Sep 17 00:00:00 2001
From: Pietro Cerutti <gahr@gahr.ch>
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
0001-chicken-install-support-building-installing-eggs-in-.patch