From e1cd54f4cccad37f7134b342c8dee9da9fa28588 Mon Sep 17 00:00:00 2001
From: zimoun <zimon.toutoune@gmail.com>
Date: Wed, 25 Aug 2021 17:32:58 +0200
Subject: [PATCH 1/1] packages: 'package-mapping' does not allocate unwritten
 package.

Reported by Ryan Prior <rprior@protonmail.com>.

* guix/packages.scm (package-mapping): Do not allocate a new package if the
procedure has no effect.
---
 guix/packages.scm | 31 +++++++++++++++++--------------
 1 file changed, 17 insertions(+), 14 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index c825f427d8..15aa67fe0a 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1058,20 +1059,22 @@ applied to implicit inputs as well."
              ;; to do that, we would build a huge object graph with lots of
              ;; duplicates, which in turns prevents us from benefiting from
              ;; memoization in 'package-derivation'.
-             (let ((p (proc p)))
-               (package
-                 (inherit p)
-                 (location (package-location p))
-                 (build-system (if deep?
-                                   (build-system-with-package-mapping
-                                    (package-build-system p) rewrite)
-                                   (package-build-system p)))
-                 (inputs (map rewrite (package-inputs p)))
-                 (native-inputs (map rewrite (package-native-inputs p)))
-                 (propagated-inputs (map rewrite (package-propagated-inputs p)))
-                 (replacement (and=> (package-replacement p) replace))
-                 (properties `((,mapping-property . #t)
-                               ,@(package-properties p)))))))))
+             (let ((new (proc p)))
+               (if (eq? new p)
+                   p
+                   (package
+                     (inherit new)
+                     (location (package-location new))
+                     (build-system (if deep?
+                                       (build-system-with-package-mapping
+                                        (package-build-system new) rewrite)
+                                       (package-build-system new)))
+                     (inputs (map rewrite (package-inputs new)))
+                     (native-inputs (map rewrite (package-native-inputs new)))
+                     (propagated-inputs (map rewrite (package-propagated-inputs new)))
+                     (replacement (and=> (package-replacement new) replace))
+                     (properties `((,mapping-property . #t)
+                                   ,@(package-properties new))))))))))
 
   replace)
 
-- 
2.32.0