See the patch attached, thanks.
--
Pietro Cerutti
I have pledged to give 10% of income to effective charities
and invite you to join me - https://givingwhatwecan.org
>From 041f97769edba2afe52f0659d510a19da491c8e5 Mon Sep 17 00:00:00 2001
From: Pietro Cerutti <[email protected]>
Date: Wed, 16 Oct 2024 19:50:41 +0000
Subject: [PATCH] chicken-install: finer-grained locking
This makes the locking in chicken-install a bit more fine-grained, just
as much as to make it possible to build multiple eggs in parallel.
Instead of locking the whole fetch+build+install (i.e., the whole
chicken-install run), I'm locking the fetch and install phases only.
Also, I have enhanced the logging a bit so we can see which process
acquires/releases/waits on the lock. Feel free to kill that part if you
don't like it.
Also also, I'm making it invalid to run `chicken-install -r` :)
---
chicken-install.scm | 23 +++++++++++++++--------
1 file changed, 15 insertions(+), 8 deletions(-)
diff --git a/chicken-install.scm b/chicken-install.scm
index 521eeda8..983abb2e 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -49,6 +49,7 @@
(import (chicken pathname))
(import (chicken process))
(import (chicken process-context))
+(import (chicken process-context posix))
(import (chicken pretty-print))
(import (chicken string))
(import (chicken bytevector))
@@ -909,7 +910,7 @@
(unless (if (member name requested-eggs) no-install
no-install-dependencies)
(check-installed-files name info)
(print "installing " name)
- (run-script dir iscript platform sudo: sudo-install))
+ (with-lock (cut run-script dir iscript platform sudo:
sudo-install)))
(when (and (member name requested-eggs)
run-tests
(not (test-egg egg platform)))
@@ -1079,9 +1080,15 @@
(create-directory cache-directory #t))
(let ((fd (file-open cache-directory open/read)))
(let loop ((f #t))
- (cond ((file-lock fd) (thunk))
+ (cond ((file-lock fd)
+ (fprintf (current-error-port) "[~A] cache acquired\n"
(current-process-id))
+ (handle-exceptions ex
+ (print-error-message ex (current-error-port))
+ (thunk)
+ (file-close fd))
+ (fprintf (current-error-port) "[~A] cache released\n"
(current-process-id)))
(else
- (when f (fprintf (current-error-port) "cache locked -
waiting for release ...\n"))
+ (when f (fprintf (current-error-port) "[~A] cache locked
- waiting for release ...\n" (current-process-id)))
(sleep 1)
(loop #f))))))))
@@ -1094,7 +1101,7 @@
(purge-mode (with-lock (cut purge-cache eggs)))
(print-repository (print (install-path)))
((null? eggs)
- (cond (list-versions-only
+ (cond ((or list-versions-only retrieve-only)
(print "no eggs specified"))
(else
(let ((files (glob "*.egg" "chicken/*.egg")))
@@ -1106,8 +1113,8 @@
(set! requested-eggs (map car canonical-eggs))
(with-lock
(lambda ()
- (retrieve-eggs '())
- (unless retrieve-only (install-eggs))))))))
+ (retrieve-eggs '())))
+ (install-eggs)))))
(else
(let ((eggs (apply-mappings eggs)))
(cond (list-versions-only (list-egg-versions eggs))
@@ -1115,8 +1122,8 @@
(set! requested-eggs (map (o car canonical) eggs))
(with-lock
(lambda ()
- (retrieve-eggs eggs)
- (unless retrieve-only (install-eggs))))))))))
+ (retrieve-eggs eggs)))
+ (unless retrieve-only (install-eggs))))))))
(define (usage code)
(print #<<EOF
--
2.46.1
