>From 9bfedfb0969cf748876b3eb81a3a7f10167cb425 Mon Sep 17 00:00:00 2001 From: Pietro Cerutti 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, when running with `-d`. Also also, I'm making it invalid to run `chicken-install -r` :) --- chicken-install.scm | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/chicken-install.scm b/chicken-install.scm index 521eeda8..2c611e48 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)) @@ -907,9 +908,11 @@ (print "building " name) (run-script dir bscript platform) (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 + (lambda () + (check-installed-files name info) + (print "installing " name) + (run-script dir iscript platform sudo: sudo-install)))) (when (and (member name requested-eggs) run-tests (not (test-egg egg platform))) @@ -1079,9 +1082,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) + (d "[~A] cache acquired\n" (current-process-id)) + (handle-exceptions ex + (print-error-message ex (current-error-port)) + (thunk) + (file-close fd)) + (d "[~A] cache released\n" (current-process-id))) (else - (when f (fprintf (current-error-port) "cache locked - waiting for release ...\n")) + (when f (d "[~A] cache locked - waiting for release ...\n" (current-process-id))) (sleep 1) (loop #f)))))))) @@ -1094,7 +1103,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 +1115,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 +1124,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 #<