Re: [patch] chicken-install: finer-grained locking

[Pietro Cerutti]

Of course the bug was evident after hitting "Send".

Here's a revised version. The whole install phase (checking for 
conflicts with already-installed eggs + actually installing the egg) 
must be guarded.

On Oct 16 2024, 19:58 +0000, Pietro Cerutti <gahr@gahr.ch> wrote:
> 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 <gahr@gahr.ch>
> 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


--
Pietro Cerutti
I have pledged to give 10% of income to effective charities
and invite you to join me - https://givingwhatwecan.org

0001-chicken-install-finer-grained-locking.patch
Description: Text document