From patchwork Thu Apr 10 14:46:54 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: David Elsing X-Patchwork-Id: 41549 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id E302727BC49; Thu, 10 Apr 2025 15:50:42 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-7.4 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED,RCVD_IN_MSPIKE_H2, RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id F3DB527BC4A for ; Thu, 10 Apr 2025 15:50:40 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1u2tEX-0001TU-11; Thu, 10 Apr 2025 10:50:25 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1u2tEI-0001Qj-Bg for guix-patches@gnu.org; Thu, 10 Apr 2025 10:50:13 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1u2tEE-00015z-Pn; Thu, 10 Apr 2025 10:50:09 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:From:To:Subject; bh=F+Cv0pSrGgyzP30Gw6whq3paMW5B9295QrVl7EpeaTs=; b=gpb8BuMJjJyv3Id2DYDnWESYJgqElQl7bpMv4Kqc4hZ1P3fGFLN6zpO32W1cg2r0ZxcY8MmDihbwaEEFDdxeArNj+Wfowo/ysObCJeYmX03iPx/BgvZ8F+KoO21Uaid/X9YhF4yTW3iGKvbj4u96Pbnd0q/ozALzTV3P5ecPtx40syC+b3mmFUZzUaQfQkjY0NzhSY8m/cDAqAvZCtDXbs6j8VxzOwbHkBsJo2KbgWTSlgKN+j0VE6SEDVAY4Kf9nrrlpwWv9HehBCJ/QT4gtDDfyqYbqeWesAE/d5YghPtkNrB6PK0ZWqWU1mF03JST9EhgmAvzUyXye6MpcKoBOw==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1u2tEA-0001ur-9f; Thu, 10 Apr 2025 10:50:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#77708] [PATCH] gexp: =?utf-8?b?4oCYd2l0aC1wYXJhbWV0ZXJz4oCY?= is respected by caches. Resent-From: David Elsing Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Thu, 10 Apr 2025 14:50:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 77708 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 77708@debbugs.gnu.org Cc: David Elsing , guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, zimon.toutoune@gmail.com, me@tobias.gr X-Debbugs-Original-To: guix-patches@gnu.org X-Debbugs-Original-Xcc: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, zimon.toutoune@gmail.com, me@tobias.gr Received: via spool by submit@debbugs.gnu.org id=B.17442965777319 (code B ref -1); Thu, 10 Apr 2025 14:50:02 +0000 Received: (at submit) by debbugs.gnu.org; 10 Apr 2025 14:49:37 +0000 Received: from localhost ([127.0.0.1]:46257 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1u2tDk-0001ty-9l for submit@debbugs.gnu.org; Thu, 10 Apr 2025 10:49:37 -0400 Received: from lists.gnu.org ([2001:470:142::17]:55902) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1u2tDh-0001tX-5e for submit@debbugs.gnu.org; Thu, 10 Apr 2025 10:49:34 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1u2tDN-0001K3-Sv for guix-patches@gnu.org; Thu, 10 Apr 2025 10:49:20 -0400 Received: from mout02.posteo.de ([185.67.36.66]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1u2tDL-000145-1c for guix-patches@gnu.org; Thu, 10 Apr 2025 10:49:13 -0400 Received: from submission (posteo.de [185.67.36.169]) by mout02.posteo.de (Postfix) with ESMTPS id 816FA240101 for ; Thu, 10 Apr 2025 16:49:07 +0200 (CEST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=posteo.net; s=2017; t=1744296547; bh=yGQGCKctIOGjlZMiRfvrJ5j4FOcjHHaHIdMWI6PKZvM=; h=From:To:Cc:Subject:Date:Message-ID:MIME-Version:Content-Type: Content-Transfer-Encoding:From; b=TyV++57UVLhdCmBGKK45+fo3U75YWXuP1e0HSeO/1Z4hoo6rHuVck4k8bIovGHCFk hvtWr6HDechZale22gKt4a238TOMdoEVbJDlORdcTOHijKFnmpxHPrMAeuOMl8AMgD oDn1x3IEcVLNRfPuiaiTkDafu5/BzXmKc3MtCynFthyZ7lLArZuncsg8Ot6Y6n1hiI l4xdU3fCbAwuYqWJpcP2VjR9eOfNGhOenDAcmaLNNJTWcpclEmodg73//fUGUgJipF PCp7IjBIW1FVbgsKvq589RoZjuNA7ILN7WAmG5XHMae3iHh5izhbF2zQcCZfIB7mIF Kks+e/YVxtZvg== Received: from customer (localhost [127.0.0.1]) by submission (posteo.de) with ESMTPSA id 4ZYN4L6rMzz9rxM; Thu, 10 Apr 2025 16:49:06 +0200 (CEST) From: David Elsing Date: Thu, 10 Apr 2025 14:46:54 +0000 Message-ID: <633ad28c062af23019c7ce7e172cec811065be18.1744296414.git.david.elsing@posteo.net> MIME-Version: 1.0 Received-SPF: pass client-ip=185.67.36.66; envelope-from=david.elsing@posteo.net; helo=mout02.posteo.de X-Spam_score_int: -43 X-Spam_score: -4.4 X-Spam_bar: ---- X-Spam_report: (-4.4 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, RCVD_IN_DNSWL_MED=-2.3, RCVD_IN_MSPIKE_H2=0.001, RCVD_IN_VALIDITY_RPBL_BLOCKED=0.001, RCVD_IN_VALIDITY_SAFE_BLOCKED=0.001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * 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 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 ;;; Copyright © 2020 Maxim Cournoyer ;;; Copyright © 2021, 2022 Maxime Devos +;;; Copyright © 2025 David Elsing ;;; ;;; 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 +;; . +(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 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 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 ;;; Copyright © 2023 Simon Tournier ;;; Copyright © 2024 Janneke Nieuwenhuizen -;;; Copyright © 2024 David Elsing +;;; Copyright © 2024, 2025 David Elsing ;;; ;;; 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 ;;; Copyright © 2021-2022 Maxime Devos +;;; Copyright © 2025 David Elsing ;;; ;;; 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")