>From 9b095e32f5e0fc4429ab18293f50e1acce908732 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. 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. The work scheduler (reduce-dag) is a self-contained function that I also intend to publish as an egg. Its code is based on what I contributed to the csm egg [1], but it's been enhanced and cleaned up. 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 | 143 ++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 131 insertions(+), 12 deletions(-) diff --git a/chicken-install.scm b/chicken-install.scm index 56c741db..c3482bc4 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)) @@ -129,6 +130,117 @@ (if (eq? mode 'target) ".target" "") (if (eq? platform 'windows) ".bat" ".sh"))) +(define (reduce-dag dag fun #!optional (max-parallelism 1) (debug #f)) + (unless (and (exact? max-parallelism) (positive? max-parallelism)) + (error 'max-parallelism "value must be a positive exact number")) + + ; no process-fork on Windows + (cond-expand + (windows + (define (bfork p) (p)) + (define (bjoin _) (values #f #f 0))) + (else + (define bfork process-fork) + (define bjoin process-wait))) + + (define (dp . args) + (if debug + (begin + (apply printf args) + (newline)))) + + (define (to-levels dag) + (dp "Reducing to levels: ~A" dag) + + (define topo + (condition-case (topological-sort dag equal?) + ((exn runtime cycle) + (error "cyclic dependencies" dag)))) + + (define (depends-on? elem lvl) + (any (lambda (lvl) + (let ((adj-list-of-a (assoc elem dag))) + (and adj-list-of-a (member lvl adj-list-of-a)))) + lvl)) + + (let loop ((topo (reverse topo)) (levs '())) + (dp "loop'ing with ~A and ~A" topo levs) + (cond + ((null? topo) + (dp "topo is null, returning levs: ~A" levs) + (reverse levs)) + ((null? levs) + (dp "levs is null, loop'ing...") + (let ((curr (car topo)) + (next (cdr topo))) + (loop next `((,curr))))) + (else + (dp "working on ~A and ~A" topo 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)) + (dp "lvl-loop'ing with ~A, ~A, ~A, and ~A" seen-lvl cand-lvl curr-lvl next-lvl) + (cond + ((depends-on? curr curr-lvl) + (dp "~A depends on ~A, loop'ing..." curr curr-lvl) + (loop next + (append seen-lvl + (cons (cons curr cand-lvl) + (cons curr-lvl next-lvl))))) + ((null? next-lvl) + (dp "next-lvl is null, loop'ing...") + (loop next + (append seen-lvl + (list cand-lvl) + (list (cons curr curr-lvl))))) + + (else + (lvl-loop + (append seen-lvl (if (null? cand-lvl) '() (list cand-lvl))) + curr-lvl + (car next-lvl) + (cdr next-lvl)))))))))) + + (define (spawn levels) + (define (make-level lvl) + (dp "making level ~A" lvl) + (if (eq? 1 max-parallelism) + (begin + (dp "for-each'ing sequentially") + (for-each fun lvl)) + (let ((slots (min (length lvl) max-parallelism))) + (let loop ((busy 0) (chunk lvl) (pids '())) + (dp "loop'ing with ~A, ~A, and ~A" busy chunk pids) + (cond + ((null? chunk) + (dp "level is done, wait for all pids") + (let ((failed (foldl + (lambda (acc x) + (let-values (((pid succ rc) (bjoin x))) + (dp "pid ~A has terminated with code ~A" pid rc) + (+ acc (if (eq? 0 rc) 0 1)))) + 0 + pids))) + (unless (zero? failed) (exit 1)))) + ((eq? busy slots) + (dp "all slots are full, wait for any pid to finish") + ; no more slots, wait for any pid to finish + (let-values (((pid succ rc) (bjoin))) + (dp "pid ~A has terminated with code ~A" pid rc) + (unless (eq? 0 rc) (exit 1)) + (loop (sub1 busy) chunk (remove (lambda (x) (eq? pid x)) pids)))) + (else + (dp "forking on ~A" (car chunk)) + (let ((pid (bfork (lambda () (fun (car chunk)))))) + (loop (add1 busy) (cdr chunk) (cons pid pids))))))))) + (for-each make-level levels)) + + (spawn (to-levels dag))) ;;; validate egg-information tree @@ -856,12 +968,11 @@ (newline))) (loop2 (cdr srvs)))))) (loop1 (cdr eggs))))))) - ;; perform installation of retrieved eggs (define (install-eggs) - (for-each + (define make-egg (lambda (egg) (let* ((name (car egg)) (dir (cadr egg)) @@ -928,16 +1039,17 @@ (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))) - -(define (order-installed-eggs) - (let* ((dag (reverse (sort-dependencies dependencies string=?))) - (ordered (filter-map (cut assoc <> canonical-eggs) dag))) - (unless quiet - (d "install order:~%") - (pp dag)) - ordered)) + (run-script dir iscript platform)))))))))) + + (unless quiet + (d "dependencies: ~A~%" dependencies)) + (reduce-dag + dependencies + (lambda (egg-name) + (let ((egg (assoc egg-name canonical-eggs))) + (when egg (make-egg egg)))) + max-procs + (not quiet))) (define (test-egg egg platform) (let* ((name (car egg)) @@ -1092,6 +1204,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 +1314,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