summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/clojure.scm3
-rw-r--r--guix/build-system/cmake.scm3
-rw-r--r--guix/build-system/go.scm3
-rw-r--r--guix/build-system/guile.scm3
-rw-r--r--guix/build-system/qt.scm3
-rw-r--r--guix/build/clojure-utils.scm2
-rw-r--r--guix/build/compile.scm32
-rw-r--r--guix/import/github.scm52
-rw-r--r--guix/import/texlive.scm8
-rw-r--r--guix/inferior.scm4
-rw-r--r--guix/packages.scm4
-rw-r--r--guix/scripts/hash.scm7
-rw-r--r--guix/scripts/shell.scm161
-rw-r--r--guix/scripts/system.scm21
-rw-r--r--guix/transformations.scm9
-rw-r--r--guix/ui.scm13
-rw-r--r--guix/utils.scm3
17 files changed, 219 insertions, 112 deletions
diff --git a/guix/build-system/clojure.scm b/guix/build-system/clojure.scm
index 39b7f44e89..634854cf1b 100644
--- a/guix/build-system/clojure.scm
+++ b/guix/build-system/clojure.scm
@@ -81,8 +81,7 @@
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME."
- (let ((private-keywords '(#:source #:target
- #:inputs #:native-inputs
+ (let ((private-keywords '(#:target #:inputs #:native-inputs
#:clojure #:jdk #:zip)))
(if target
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index 2056c04153..0aabc95b90 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2015, 2020-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
@@ -240,6 +240,7 @@ build system."
#:parallel-tests? #$parallel-tests?
#:validate-runpath? #$validate-runpath?
#:patch-shebangs? #$patch-shebangs?
+ #:make-dynamic-linker-cache? #f ;cross-compiling
#:strip-binaries? #$strip-binaries?
#:strip-flags #$strip-flags
#:strip-directories #$strip-directories))))
diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm
index 09148f8730..5e0e5bbad3 100644
--- a/guix/build-system/go.scm
+++ b/guix/build-system/go.scm
@@ -2,7 +2,7 @@
;;; Copyright © 2016 Petter <petter@mykolab.ch>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
-;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;;
@@ -276,6 +276,7 @@ commit hash and its date rather than a proper release tag."
#:unpack-path #$unpack-path
#:build-flags #$build-flags
#:tests? #$tests?
+ #:make-dynamic-linker-cache? #f ;cross-compiling
#:allow-go-reference? #$allow-go-reference?
#:inputs %build-inputs)))
diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm
index f64f214675..36a88e181a 100644
--- a/guix/build-system/guile.scm
+++ b/guix/build-system/guile.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2019, 2021-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -162,6 +162,7 @@
#:native-search-paths '#$(map
search-path-specification->sexp
native-search-paths)
+ #:make-dynamic-linker-cache? #f ;cross-compiling
#:phases #$phases))))
(mlet %store-monad ((guile (package->derivation (or guile (default-guile))
diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm
index 003a065aa6..a0b968cef3 100644
--- a/guix/build-system/qt.scm
+++ b/guix/build-system/qt.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2015, 2021-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -247,6 +247,7 @@ build system."
#:parallel-tests? #$parallel-tests?
#:validate-runpath? #$validate-runpath?
#:patch-shebangs? #$patch-shebangs?
+ #:make-dynamic-linker-cache? #f ;cross-compiling
#:strip-binaries? #$strip-binaries?
#:strip-flags #$strip-flags
#:strip-directories #$strip-directories))))
diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm
index a9ffad3c8f..8817cab52a 100644
--- a/guix/build/clojure-utils.scm
+++ b/guix/build/clojure-utils.scm
@@ -135,7 +135,7 @@ all libraries found under the source directories."
(define-with-docs %aot-exclude
"A default list of symbols deciding what not to compile.
See the doc string of '%aot-include' for more details."
- '())
+ '(data-readers))
(define-with-docs %tests?
"Enable tests by default."
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index b86ec3b743..82761a2190 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2014, 2016-2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -37,6 +37,21 @@
;;;
;;; Code:
+(define (strip-keyword-arguments keywords args) ;XXX: copied from (guix utils)
+ "Remove all of the keyword arguments listed in KEYWORDS from ARGS."
+ (let loop ((args args)
+ (result '()))
+ (match args
+ (()
+ (reverse result))
+ (((? keyword? kw) arg . rest)
+ (loop rest
+ (if (memq kw keywords)
+ result
+ (cons* arg kw result))))
+ ((head . tail)
+ (loop tail (cons head result))))))
+
(define optimizations-for-level
(or (and=> (false-if-exception
(resolve-interface '(system base optimize)))
@@ -60,9 +75,18 @@
(loop rest `(#f ,kw ,@result))))))
(lambda (level)
- (if (<= level 1)
- %lightweight-optimizations
- %default-optimizations)))))
+ ;; In the upcoming Guile 3.0.8, .go files include code of their
+ ;; inlinable exports and free variables are resolved at compile time
+ ;; (both are enabled at -O1) to permit cross-module inlining
+ ;; (enabled at -O2). Unfortunately, this currently leads to
+ ;; non-reproducible and more expensive builds, so we turn it off
+ ;; here:
+ ;; <https://wingolog.org/archives/2021/05/13/cross-module-inlining-in-guile>.
+ (strip-keyword-arguments '(#:inlinable-exports? #:resolve-free-vars?
+ #:cross-module-inlining?)
+ (if (<= level 1)
+ %lightweight-optimizations
+ %default-optimizations))))))
(define (supported-warning-type? type)
"Return true if TYPE, a symbol, denotes a supported warning type."
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 888b148ffb..8c1898c0c5 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -25,6 +26,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-71)
#:use-module (guix utils)
#:use-module (guix i18n)
#:use-module (guix diagnostics)
@@ -37,7 +39,10 @@
#:use-module (guix upstream)
#:use-module (guix http-client)
#:use-module (web uri)
- #:export (%github-updater))
+ #:export (%github-api %github-updater))
+
+;; For tests.
+(define %github-api (make-parameter "https://api.github.com"))
(define (find-extension url)
"Return the extension of the archive e.g. '.tar.gz' given a URL, or
@@ -148,11 +153,11 @@ tags show up in the \"Releases\" tab of the web UI. For instance,
'https://api.github.com/repos/aconchillo/guile-json/releases' returns the
empty list."
(define release-url
- (string-append "https://api.github.com/repos/"
+ (string-append (%github-api) "/repos/"
(github-user-slash-repository url)
"/releases"))
(define tag-url
- (string-append "https://api.github.com/repos/"
+ (string-append (%github-api) "/repos/"
(github-user-slash-repository url)
"/tags"))
@@ -181,12 +186,15 @@ empty list."
(x x)))))
(define (latest-released-version url package-name)
- "Return a string of the newest released version name given a string URL like
+ "Return the newest released version and its tag given a string URL like
'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
-the package e.g. 'bedtools2'. Return #f if there is no releases"
+the package e.g. 'bedtools2'. Return #f (two values) if there are no
+releases."
(define (pre-release? x)
(assoc-ref x "prerelease"))
+ ;; This procedure returns (version . tag) pair, or #f
+ ;; if RELEASE doesn't seyem to correspond to a version.
(define (release->version release)
(let ((tag (or (assoc-ref release "tag_name") ;a "release"
(assoc-ref release "name"))) ;a tag
@@ -197,22 +205,22 @@ the package e.g. 'bedtools2'. Return #f if there is no releases"
((and (< name-length (string-length tag))
(string=? (string-append package-name "-")
(substring tag 0 (+ name-length 1))))
- (substring tag (+ name-length 1)))
+ (cons (substring tag (+ name-length 1)) tag))
;; some tags start with a "v" e.g. "v0.25.0"
;; or with the word "version" e.g. "version.2.1"
;; where some are just the version number
((string-prefix? "version" tag)
- (if (char-set-contains? char-set:digit (string-ref tag 7))
- (substring tag 7)
- (substring tag 8)))
+ (cons (if (char-set-contains? char-set:digit (string-ref tag 7))
+ (substring tag 7)
+ (substring tag 8)) tag))
((string-prefix? "v" tag)
- (substring tag 1))
+ (cons (substring tag 1) tag))
;; Finally, reject tags that don't start with a digit:
;; they may not represent a release.
((and (not (string-null? tag))
(char-set-contains? char-set:digit
(string-ref tag 0)))
- tag)
+ (cons tag tag))
(else #f))))
(let* ((json (and=> (fetch-releases-or-tags url)
@@ -229,14 +237,14 @@ https://github.com/settings/tokens"))
(match (remove pre-release? json)
(() json) ; keep everything
(releases releases)))
- version>?)
- ((latest-release . _) latest-release)
- (() #f)))))
+ (lambda (x y) (version>? (car x) (car y))))
+ (((latest-version . tag) . _) (values latest-version tag))
+ (() (values #f #f))))))
(define (latest-release pkg)
"Return an <upstream-source> for the latest release of PKG."
- (define (origin-github-uri origin)
- (match (origin-uri origin)
+ (define (github-uri uri)
+ (match uri
((? string? url)
url) ;surely a github.com URL
((? download:git-reference? ref)
@@ -244,14 +252,20 @@ https://github.com/settings/tokens"))
((urls ...)
(find (cut string-contains <> "github.com") urls))))
- (let* ((source-uri (origin-github-uri (package-source pkg)))
+ (let* ((original-uri (origin-uri (package-source pkg)))
+ (source-uri (github-uri original-uri))
(name (package-name pkg))
- (newest-version (latest-released-version source-uri name)))
+ (newest-version version-tag
+ (latest-released-version source-uri name)))
(if newest-version
(upstream-source
(package name)
(version newest-version)
- (urls (list (updated-github-url pkg newest-version))))
+ (urls (if (download:git-reference? original-uri)
+ (download:git-reference
+ (inherit original-uri)
+ (commit version-tag))
+ (list (updated-github-url pkg newest-version)))))
#f))) ; On GitHub but no proper releases
(define %github-updater
diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm
index d5021669be..77b3c6380c 100644
--- a/guix/import/texlive.scm
+++ b/guix/import/texlive.scm
@@ -239,10 +239,10 @@
,@(or (and=> (assoc-ref data 'depend)
(lambda (inputs)
`((propagated-inputs
- ,(map (lambda (tex-name)
- (let ((name (guix-name tex-name)))
- (list name (list 'unquote (string->symbol name)))))
- inputs)))))
+ (list ,@(map (lambda (tex-name)
+ (let ((name (guix-name tex-name)))
+ (string->symbol name)))
+ inputs))))))
'())
,@(or (and=> (assoc-ref data 'catalogue-ctan)
(lambda (url)
diff --git a/guix/inferior.scm b/guix/inferior.scm
index febac29766..783be64fa4 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -815,7 +815,7 @@ determines whether CHANNELS are authenticated."
(add-indirect-root* cached)
(return cached))
(mbegin %store-monad
- (add-temp-root* profile)
+ (add-temp-root* (derivation->output-path profile))
(return profile))))))))
(define* (inferior-for-channels channels
diff --git a/guix/packages.scm b/guix/packages.scm
index da8b66dfa6..9d5b23eb8a 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -395,7 +395,7 @@ from forcing GEXP-PROMISE."
;; This is the list of system types that are supported. By default, we
;; expect all packages to build successfully here.
'("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"
- "powerpc64le-linux" "powerpc-linux"))
+ "powerpc64le-linux" "powerpc-linux" "riscv64-linux"))
(define %hurd-systems
;; The GNU/Hurd systems for which support is being developed.
@@ -406,7 +406,7 @@ from forcing GEXP-PROMISE."
;;
;; XXX: MIPS is unavailable in CI:
;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
- (fold delete %supported-systems '("mips64el-linux" "powerpc-linux")))
+ (fold delete %supported-systems '("mips64el-linux" "powerpc-linux" "riscv64-linux")))
(define-inlinable (sanitize-inputs inputs)
"Sanitize INPUTS by turning it into a list of name/package tuples if it's
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index 9715dc7779..4e792c6a03 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2014, 2016-2017, 2020-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
@@ -134,8 +134,9 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
(alist-delete 'format result))))
(option '(#\r "recursive") #f #f
(lambda (opt name arg result)
- (warning (G_ "'--recursive' is deprecated, \
-use '--serializer' instead~%"))
+ (unless (eqv? name #\r)
+ (warning (G_ "'--recursive' is deprecated, \
+use '--serializer=nar' instead~%")))
(alist-cons 'serializer nar-hash
(alist-delete 'serializer result))))
(option '(#\S "serializer") #t #f
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 546639818f..a92932cbc9 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,7 +21,8 @@
#:use-module ((guix diagnostics) #:select (location))
#:use-module (guix scripts environment)
#:autoload (guix scripts build) (show-build-options-help)
- #:autoload (guix transformations) (show-transformation-options-help)
+ #:autoload (guix transformations) (transformation-option-key?
+ show-transformation-options-help)
#:use-module (guix scripts)
#:use-module (guix packages)
#:use-module (guix profiles)
@@ -40,6 +41,7 @@
#:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (guix cache)
#:use-module ((ice-9 ftw) #:select (scandir))
+ #:autoload (gnu packages) (cache-is-authoritative?)
#:export (guix-shell))
(define (show-help)
@@ -201,51 +203,35 @@ a hash-prefixed comment, or a blank line."
(const #f)))
(define (options-with-caching opts)
- "If OPTS contains exactly one 'load' or one 'manifest' key, automatically
-add a 'profile' key (when a profile for that file is already in cache) or a
-'gc-root' key (to add the profile to cache)."
- (define (single-file-for-caching opts)
- (let loop ((opts opts)
- (file #f))
- (match opts
- (() file)
- ((('package . _) . _) #f)
- ((('load . ('package candidate)) . rest)
- (and (not file) (loop rest candidate)))
- ((('manifest . candidate) . rest)
- (and (not file) (loop rest candidate)))
- ((('expression . _) . _) #f)
- ((_ . rest) (loop rest file)))))
-
- ;; Check whether there's a single 'load' or 'manifest' option. When that is
- ;; the case, arrange to automatically cache the resulting profile.
- (match (single-file-for-caching opts)
- (#f opts)
- (file
- (let* ((root (profile-cached-gc-root file))
- (stat (and root (false-if-exception (lstat root)))))
- (if (and (not (assoc-ref opts 'rebuild-cache?))
- stat
- (<= (stat:mtime ((@ (guile) stat) file))
- (stat:mtime stat)))
- (let ((now (current-time)))
- ;; Update the atime on ROOT to reflect usage.
- (utime root
- now (stat:mtime stat) 0 (stat:mtimensec stat)
- AT_SYMLINK_NOFOLLOW)
- (alist-cons 'profile root
- (remove (match-lambda
- (('load . _) #t)
- (('manifest . _) #t)
- (_ #f))
- opts))) ;load right away
- (if (and root (not (assq-ref opts 'gc-root)))
- (begin
- (if stat
- (delete-file root)
- (mkdir-p (dirname root)))
- (alist-cons 'gc-root root opts))
- opts))))))
+ "If OPTS contains only options that allow us to compute a cache key,
+automatically add a 'profile' key (when a profile for that file is already in
+cache) or a 'gc-root' key (to add the profile to cache)."
+ ;; Attempt to compute a file name for use as the cached profile GC root.
+ (let* ((root timestamp (profile-cached-gc-root opts))
+ (stat (and root (false-if-exception (lstat root)))))
+ (if (and (not (assoc-ref opts 'rebuild-cache?))
+ stat
+ (<= timestamp (stat:mtime stat)))
+ (let ((now (current-time)))
+ ;; Update the atime on ROOT to reflect usage.
+ (utime root
+ now (stat:mtime stat) 0 (stat:mtimensec stat)
+ AT_SYMLINK_NOFOLLOW)
+ (alist-cons 'profile root
+ (remove (match-lambda
+ (('load . _) #t)
+ (('manifest . _) #t)
+ (('package . _) #t)
+ (('ad-hoc-package . _) #t)
+ (_ #f))
+ opts))) ;load right away
+ (if (and root (not (assq-ref opts 'gc-root)))
+ (begin
+ (if stat
+ (delete-file root)
+ (mkdir-p (dirname root)))
+ (alist-cons 'gc-root root opts))
+ opts))))
(define (auto-detect-manifest opts)
"If OPTS do not specify packages or a manifest, load a \"guix.scm\" or
@@ -308,28 +294,87 @@ echo ~a >> ~a
(make-parameter (string-append (cache-directory #:ensure? #f)
"/profiles")))
-(define (profile-cache-key file)
+(define (profile-cache-primary-key)
+ "Return the \"primary key\" used when computing keys for the profile cache.
+Return #f if no such key can be obtained and caching cannot be
+performed--e.g., because the package cache is not authoritative."
+ (and (cache-is-authoritative?)
+ (match (current-channels)
+ (()
+ #f)
+ (((= channel-commit commits) ...)
+ (string-join commits)))))
+
+(define (profile-file-cache-key file system)
"Return the cache key for the profile corresponding to FILE, a 'guix.scm' or
'manifest.scm' file, or #f if we lack channel information."
- (match (current-channels)
- (() #f)
- (((= channel-commit commits) ...)
+ (match (profile-cache-primary-key)
+ (#f #f)
+ (primary-key
(let ((stat (stat file)))
(bytevector->base32-string
;; Since FILE is not canonicalized, only include the device/inode
;; numbers. XXX: In some rare cases involving Btrfs and NFS, this can
;; be insufficient: <https://lwn.net/Articles/866582/>.
(sha256 (string->utf8
- (string-append (string-join commits) ":"
+ (string-append primary-key ":" system ":"
(number->string (stat:dev stat)) ":"
(number->string (stat:ino stat))))))))))
-(define (profile-cached-gc-root file)
- "Return the cached GC root for FILE, a 'guix.scm' or 'manifest.scm' file, or
-#f if we lack information to cache it."
- (match (profile-cache-key file)
- (#f #f)
- (key (string-append (%profile-cache-directory) "/" key))))
+(define (profile-spec-cache-key specs system)
+ "Return the cache key corresponding to SPECS built for SYSTEM, where SPECS
+is a list of package specs. Return #f if caching is not possible."
+ (match (profile-cache-primary-key)
+ (#f #f)
+ (primary-key
+ (bytevector->base32-string
+ (sha256 (string->utf8
+ (string-append primary-key ":" system ":"
+ (object->string specs))))))))
+
+(define (profile-cached-gc-root opts)
+ "Return two values: the file name of a GC root for use as a profile cache
+for the options in OPTS, and a timestamp which, if greater than the GC root's
+mtime, indicates that the GC root is stale. If OPTS do not permit caching,
+return #f and #f."
+ (define (key->file key)
+ (string-append (%profile-cache-directory) "/" key))
+
+ (let loop ((opts opts)
+ (system (%current-system))
+ (file #f)
+ (specs '()))
+ (match opts
+ (()
+ (if file
+ (values (and=> (profile-file-cache-key file system) key->file)
+ (stat:mtime (stat file)))
+ (values (and=> (profile-spec-cache-key specs system) key->file)
+ 0)))
+ (((and spec ('package . _)) . rest)
+ (if (not file)
+ (loop rest system file (cons spec specs))
+ (values #f #f)))
+ ((('load . ('package candidate)) . rest)
+ (if (and (not file) (null? specs))
+ (loop rest system candidate specs)
+ (values #f #f)))
+ ((('manifest . candidate) . rest)
+ (if (and (not file) (null? specs))
+ (loop rest system candidate specs)
+ (values #f #f)))
+ ((('expression . _) . _)
+ ;; Arbitrary expressions might be non-deterministic or otherwise depend
+ ;; on external state so do not cache when they're used.
+ (values #f #f))
+ ((((? transformation-option-key?) . _) . _)
+ ;; Transformation options are potentially "non-deterministic", or at
+ ;; least depending on external state (with-source, with-commit, etc.),
+ ;; so do not cache anything when they're used.
+ (values #f #f))
+ ((('system . system) . rest)
+ (loop rest system file specs))
+ ((_ . rest) (loop rest system file specs)))))
;;;
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 98e788c657..414e931c8a 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -772,7 +772,7 @@ and TARGET arguments."
dry-run? derivations-only?
use-substitutes? target
full-boot?
- volatile?
+ volatile-vm-root?
(graphic? #t)
container-shared-network?
(mappings '())
@@ -827,7 +827,8 @@ static checks."
(mlet* %store-monad
((sys (system-derivation-for-action image action
#:full-boot? full-boot?
- #:volatile? volatile?
+ #:volatile?
+ volatile-vm-root?
#:graphic? graphic?
#:container-shared-network? container-shared-network?
#:mappings mappings))
@@ -999,6 +1000,8 @@ Some ACTIONS support additional ARGS.\n"))
(display (G_ "
--volatile for 'image', make the root file system volatile"))
(display (G_ "
+ --persistent for 'vm', make the root file system persistent"))
+ (display (G_ "
--label=LABEL for 'image', label disk image with LABEL"))
(display (G_ "
--save-provenance save provenance information"))
@@ -1080,7 +1083,10 @@ Some ACTIONS support additional ARGS.\n"))
(alist-cons 'install-bootloader? #f result)))
(option '("volatile") #f #f
(lambda (opt name arg result)
- (alist-cons 'volatile-root? #t result)))
+ (alist-cons 'volatile-image-root? #t result)))
+ (option '("persistent") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'volatile-vm-root? #f result)))
(option '("label") #t #f
(lambda (opt name arg result)
(alist-cons 'label arg result)))
@@ -1149,7 +1155,8 @@ Some ACTIONS support additional ARGS.\n"))
(image-size . guess)
(install-bootloader? . #t)
(label . #f)
- (volatile-root? . #f)
+ (volatile-image-root? . #f)
+ (volatile-vm-root? . #t)
(graph-backend . "graphviz")))
(define (verbosity-level opts)
@@ -1219,7 +1226,8 @@ resulting from command-line parsing."
((docker-image) docker-image-type)
(else image-type)))
(image-size (assoc-ref opts 'image-size))
- (volatile? (assoc-ref opts 'volatile-root?))
+ (volatile?
+ (assoc-ref opts 'volatile-image-root?))
(shared-network?
(assoc-ref opts 'container-shared-network?))
(base-image (if (operating-system? obj)
@@ -1279,7 +1287,8 @@ resulting from command-line parsing."
#:validate-reconfigure
(assoc-ref opts 'validate-reconfigure)
#:full-boot? (assoc-ref opts 'full-boot?)
- #:volatile? (assoc-ref opts 'volatile-root?)
+ #:volatile-vm-root?
+ (assoc-ref opts 'volatile-vm-root?)
#:graphic? (not (assoc-ref opts 'no-graphic?))
#:container-shared-network?
(assoc-ref opts 'container-shared-network?)
diff --git a/guix/transformations.scm b/guix/transformations.scm
index c43c00cdd3..0976f0d824 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
;;;
;;; This file is part of GNU Guix.
@@ -56,6 +56,7 @@
tuned-package
show-transformation-options-help
+ transformation-option-key?
%transformation-options))
;;; Commentary:
@@ -796,6 +797,12 @@ are replaced by their latest upstream version."
(and (eq? k key) proc)))
%transformations))
+(define (transformation-option-key? key)
+ "Return true if KEY is an option key (as returned while parsing options with
+%TRANSFORMATION-OPTIONS) corresponding to a package transformation option.
+For example, (transformation-option-key? 'with-input) => #t."
+ (->bool (transformation-procedure key)))
+
;;;
;;; Command-line handling.
diff --git a/guix/ui.scm b/guix/ui.scm
index 251a3a4ab9..fc6f44e9ea 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
@@ -1514,13 +1514,15 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate."
;; the initial "+ " prefix.
(if (> width 2) (- width 2) width))
+ (define (split-lines str indent)
+ (string->recutils
+ (fill-paragraph str width* indent)))
+
(define (dependencies->recutils packages)
(let ((list (string-join (delete-duplicates
(map package-full-name
(sort packages package<?))) " ")))
- (string->recutils
- (fill-paragraph list width*
- (string-length "dependencies: ")))))
+ (split-lines list (string-length "dependencies: "))))
(define (package<? p1 p2)
(string<? (package-full-name p1) (package-full-name p2)))
@@ -1530,7 +1532,8 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate."
(format port "version: ~a~%" (package-version p))
(format port "outputs: ~a~%" (string-join (package-outputs p)))
(format port "systems: ~a~%"
- (string-join (package-transitive-supported-systems p)))
+ (split-lines (string-join (package-transitive-supported-systems p))
+ (string-length "systems: ")))
(format port "dependencies: ~a~%"
(match (package-direct-inputs p)
(((labels inputs . _) ...)
diff --git a/guix/utils.scm b/guix/utils.scm
index 536323978e..cba6464523 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -712,7 +712,8 @@ architecture (x86_64)?"
(define* (target-64bit? #:optional (system (or (%current-target-system)
(%current-system))))
- (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64")))
+ (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64"
+ "powerpc64" "riscv64")))
(define* (cc-for-target #:optional (target (%current-target-system)))
(if target
generated by cgit v1.2.3 (git 2.45.0) at 2024-06-19 22:49:14 +0000