Package: guix-patches;
Reported by: David Elsing <david.elsing <at> posteo.net>
Date: Thu, 10 Apr 2025 14:50:02 UTC
Severity: normal
Tags: patch
View this message in rfc822 format
From: David Elsing <david.elsing <at> posteo.net> To: 77708 <at> debbugs.gnu.org Cc: David Elsing <david.elsing <at> posteo.net>, guix <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, zimon.toutoune <at> gmail.com, me <at> tobias.gr Subject: [bug#77708] [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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.