GNU bug report logs - #77708
[PATCH] gexp: ‘with-parameters‘ is respected by caches.

Previous Next

To reply to this bug, email your comments to 77708 AT debbugs.gnu.org.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: David Elsing <david.elsing <at> posteo.net>
To: guix-patches <at> gnu.org
Cc: David Elsing <david.elsing <at> posteo.net>
Subject: [PATCH] gexp: ‘with-parameters‘ is respected by caches.
Date: Thu, 10 Apr 2025 14:46:54 +0000

* guix/gexp.scm (lower-object, lower+expand-object):
Use (%parameterized-counter) as additional cache key.
(%parameterized-counter): New parameter.
(%parameterized-counter-next-value): New variable.
(%parameterized-counters): New variable.
(add-parameterized-counter): New procedure.
(compile-parameterized): Add %parameterized-counter to parameters.
* guix/packages.scm (cache!): Use ‘hash-set!‘ instead of ‘hashq-set!‘. Use
`(,(scm->pointer package) . ,(%parameterized-counter)) as key.
(cached, package->derivation, package->cross-derivation):
Use (%parameterized-counter) as additional cache key.
* tests/gexp.scm ("with-parameters for custom parameter"): New test.
---
As noted by Ludo' [1], several objects dependent on packages
(such as derivations or grafts) are cached by the package and do not
take parameters (apart from %current-system, %current-target-system and
%graft?) into account. To fix that, my idea was to introduce an
additional parameter `%parameterized-counter', which uniquely identifies
a set of parameters and values in the <parameterized> object and which
is used as additional key by the caches.

To prevent a collision, the parameters and values are stored in a hash table,
which keeps them alive forever. Would it be preferable to use something like a
cryptographic hash instead?

For `cache!' in (guix packages), I used
`(,(scm->pointer package) . ,(%parameterized-counter)) as key together with
hash-set! and hash-ref instead of hashq-set! and hashq-ref. Is that OK?

[1] https://issues.guix.gnu.org/75879

 guix/gexp.scm     | 48 +++++++++++++++++++++++++++++++++++++++--------
 guix/packages.scm | 22 +++++++++++-----------
 tests/gexp.scm    | 31 ++++++++++++++++++++++++++++++
 3 files changed, 82 insertions(+), 19 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 8dd746eee0..11e3b5968f 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe <at> gmail.com>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
 ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos <at> telenet.be>
+;;; Copyright © 2025 David Elsing <david.elsing <at> posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,6 +33,7 @@ (define-module (guix gexp)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -94,6 +96,7 @@ (define-module (guix gexp)
 
             with-parameters
             parameterized?
+            %parameterized-counter
 
             load-path-expression
             gexp-modules
@@ -302,7 +305,7 @@ (define* (lower-object obj
                                  (not (derivation? lowered)))
                             (loop lowered)
                             (return lowered)))
-                      obj
+                      obj (%parameterized-counter)
                       system target graft?)))))))
 
 (define* (lower+expand-object obj
@@ -321,7 +324,7 @@ (define* (lower+expand-object obj
                             (lowered (if (derivation? obj)
                                          (return obj)
                                          (mcached (lower obj system target)
-                                                  obj
+                                                  obj (%parameterized-counter)
                                                   system target graft?))))
          ;; LOWER might return something that needs to be further
          ;; lowered.
@@ -731,13 +734,40 @@ (define-syntax-rule (with-parameters ((param value) ...) body ...)
                  (lambda ()
                    body ...)))
 
+;; Counter which uniquely identifies specific parameters and values used for
+;; <parameterized>.
+(define %parameterized-counter
+  (make-parameter #f))
+
+(define %parameterized-counter-next-value 0)
+
+(define %parameterized-counters (make-hash-table))
+
+;; Add %parameterized-counter to PARAMETERS and its value,
+;; which depends on PARAMETERS and VALUES, to PARAMETER-VALUES.
+(define (add-parameterized-counter parameters parameter-values)
+  (let* ((key `(,parameters . ,parameter-values))
+         (counter
+          (match (hash-ref %parameterized-counters key)
+            (#f
+             (let ((val %parameterized-counter-next-value))
+               (hash-set! %parameterized-counters key val)
+               (set! %parameterized-counter-next-value (+ val 1))
+               val))
+            (counter counter))))
+    (values
+     (cons %parameterized-counter parameters)
+     (cons counter parameter-values))))
+
 (define-gexp-compiler compile-parameterized <parameterized>
   compiler =>
   (lambda (parameterized system target)
     (match (parameterized-bindings parameterized)
       (((parameters values) ...)
-       (let ((thunk (parameterized-thunk parameterized))
-             (values (map (lambda (thunk) (thunk)) values)))
+       (let*-values (((parameters values)
+                      (add-parameterized-counter
+                       parameters (map (lambda (thunk) (thunk)) values)))
+                     ((thunk) (parameterized-thunk parameterized)))
          ;; Install the PARAMETERS for the store monad.
          (state-with-parameters parameters values
            ;; Install the PARAMETERS for the dynamic extent of THUNK.
@@ -762,11 +792,13 @@ (define-gexp-compiler compile-parameterized <parameterized>
   expander => (lambda (parameterized lowered output)
                 (match (parameterized-bindings parameterized)
                   (((parameters values) ...)
-                   (let ((fluids (map parameter-fluid parameters))
-                         (thunk  (parameterized-thunk parameterized)))
+                   (let*-values (((parameters values)
+                                  (add-parameterized-counter
+                                   parameters (map (lambda (thunk) (thunk)) values)))
+                                 ((thunk)  (parameterized-thunk parameterized)))
                      ;; Install the PARAMETERS for the dynamic extent of THUNK.
-                     (with-fluids* fluids
-                       (map (lambda (thunk) (thunk)) values)
+                     (with-fluids* (map parameter-fluid parameters)
+                       values
                        (lambda ()
                          (match (thunk)
                            ((? struct? base)
diff --git a/guix/packages.scm b/guix/packages.scm
index 18ab23e0aa..1ee456ced2 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -11,7 +11,7 @@
 ;;; Copyright © 2022 jgart <jgart <at> dismail.de>
 ;;; Copyright © 2023 Simon Tournier <zimon.toutoune <at> gmail.com>
 ;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke <at> gnu.org>
-;;; Copyright © 2024 David Elsing <david.elsing <at> posteo.net>
+;;; Copyright © 2024, 2025 David Elsing <david.elsing <at> posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,6 +57,7 @@ (define-module (guix packages)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-71)
+  #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
   #:use-module (web uri)
   #:autoload   (texinfo) (texi-fragment->stexi)
@@ -1689,13 +1690,12 @@ (define (cache! cache package system thunk)
 SYSTEM."
   ;; FIXME: This memoization should be associated with the open store, because
   ;; otherwise it breaks when switching to a different store.
-  (let ((result (thunk)))
-    ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
-    ;; same value for all structs (as of Guile 2.0.6), and because pointer
-    ;; equality is sufficient in practice.
-    (hashq-set! cache package
-                `((,system . ,result)
-                  ,@(or (hashq-ref cache package) '())))
+  (let ((result (thunk))
+        (key `(,(scm->pointer package) . ,(%parameterized-counter))))
+    (hash-set! cache key
+               `((,system . ,result)
+                 ,@(or (hash-ref cache key)
+                       '())))
     result))
 
 (define-syntax cached
@@ -1828,7 +1828,7 @@ (define (input-graft system)
                                    (with-parameters ((%current-system system))
                                      replacement))
                                   (replacement-output output))))
-                      package output system)
+                      package output (%parameterized-counter) system)
              (return #f))))
       (_
        (return #f)))))
@@ -2068,7 +2068,7 @@ (define* (package->derivation package
                                               #:system system
                                               #:guile guile)))))
                  (return drv)))
-           package system #f graft?))
+           package (%parameterized-counter) system #f graft?))
 
 (define* (package->cross-derivation package target
                                     #:optional (system (%current-system))
@@ -2091,7 +2091,7 @@ (define* (package->cross-derivation package target
                                               #:system system
                                               #:guile guile)))))
                  (return drv)))
-           package system target graft?))
+           package (%parameterized-counter) system target graft?))
 
 (define* (package-output store package
                          #:optional (output "out") (system (%current-system)))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 00bb729e76..91819806d0 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014-2025 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2021-2022 Maxime Devos <maximedevos <at> telenet.be>
+;;; Copyright © 2025 David Elsing <david.elsing <at> posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -487,6 +488,36 @@ (define (match-input thing)
     (return (and (eq? drv0 result0)
                  (eq? drv1 result1)))))
 
+(test-assertm "with-parameters for custom parameter"
+  (mlet* %store-monad
+      ((%param -> (make-parameter "A"))
+       (pkg -> (package
+                 (name "testp")
+                 (version "0")
+                 (source #f)
+                 (build-system trivial-build-system)
+                 (arguments
+                  (list
+                   #:builder
+                   #~(let ((port (open-file (string-append #$output) "w")))
+                       (display (string-append #$(%param) "\n") port)
+                       (close-port port))))
+                 (home-page #f)
+                 (synopsis #f)
+                 (description #f)
+                 (license #f)))
+       (obj1 -> (with-parameters ((%param "B")) pkg))
+       (obj2 -> (with-parameters ((%param "C")) pkg))
+       (result0 (package->derivation pkg))
+       (result1 (lower-object obj1))
+       (result2 (lower-object obj2))
+       (result3 (lower-object pkg)))
+    (return (and (not
+                  (or (eq? result0 result1)
+                      (eq? result0 result2)
+                      (eq? result1 result2)))
+                 (eq? result0 result3)))))
+
 (test-assert "with-parameters + file-append"
   (let* ((system (match (%current-system)
                    ("aarch64-linux" "x86_64-linux")
-- 
2.48.1

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.