diff options
Diffstat (limited to 'guix/profiles.scm')
| -rw-r--r-- | guix/profiles.scm | 178 |
1 files changed, 136 insertions, 42 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm index 3a6498993c..ab265cce62 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -87,6 +87,9 @@ manifest-entry-search-paths manifest-entry-parent manifest-entry-properties + lower-manifest-entry + + manifest-entry=? manifest-pattern manifest-pattern? @@ -122,6 +125,15 @@ profile-derivation profile-search-paths + profile + profile? + profile-name + profile-content + profile-hooks + profile-locales? + profile-allow-collisions? + profile-relative-symlinks? + generation-number generation-profile generation-numbers @@ -216,6 +228,33 @@ (output manifest-pattern-output ; string | #f (default "out"))) +(define (list=? = lst1 lst2) + "Return true if LST1 and LST2 have the same length and their elements are +pairwise equal per =." + (match lst1 + (() + (null? lst2)) + ((head1 . tail1) + (match lst2 + ((head2 . tail2) + (and (= head1 head2) (list=? = tail1 tail2))) + (() + #f))))) + +(define (manifest-entry=? entry1 entry2) + "Return true if ENTRY1 is equivalent to ENTRY2, ignoring their 'properties' +field." + (match entry1 + (($ <manifest-entry> name1 version1 output1 item1 dependencies1 paths1) + (match entry2 + (($ <manifest-entry> name2 version2 output2 item2 dependencies2 paths2) + (and (string=? name1 name2) + (string=? version1 version2) + (string=? output1 output2) + (equal? item1 item2) ;XXX: could be <package> vs. store item + (equal? paths1 paths2) + (list=? manifest-entry=? dependencies1 dependencies2))))))) + (define (manifest-transitive-entries manifest) "Return the entries of MANIFEST along with their propagated inputs, recursively." @@ -263,16 +302,24 @@ procedure takes two arguments: the entry name and output." (define* (lower-manifest-entry entry system #:key target) "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store file name." + (define (recurse entry) + (mapm/accumulate-builds (lambda (entry) + (lower-manifest-entry entry system + #:target target)) + (manifest-entry-dependencies entry))) + (let ((item (manifest-entry-item entry))) (if (string? item) (with-monad %store-monad (return entry)) (mlet %store-monad ((drv (lower-object item system #:target target)) + (dependencies (recurse entry)) (output -> (manifest-entry-output entry))) (return (manifest-entry (inherit entry) - (item (derivation->output-path drv output)))))))) + (item (derivation->output-path drv output)) + (dependencies dependencies))))))) (define* (check-for-collisions manifest system #:key target) "Check whether the entries of MANIFEST conflict with one another; raise a @@ -280,29 +327,37 @@ file name." (define lookup (manifest-entry-lookup manifest)) - (with-monad %store-monad + (define candidates + (filter-map (lambda (entry) + (let ((other (lookup (manifest-entry-name entry) + (manifest-entry-output entry)))) + (and other (list entry other)))) + (manifest-transitive-entries manifest))) + + (define lower-pair + (match-lambda + ((first second) + (mlet %store-monad ((first (lower-manifest-entry first system + #:target target)) + (second (lower-manifest-entry second system + #:target target))) + (return (list first second)))))) + + ;; Start by lowering CANDIDATES "in parallel". + (mlet %store-monad ((lst (mapm/accumulate-builds lower-pair candidates))) (foldm %store-monad - (lambda (entry result) - (match (lookup (manifest-entry-name entry) - (manifest-entry-output entry)) - ((? manifest-entry? second) ;potential conflict - (mlet %store-monad ((first (lower-manifest-entry entry system - #:target - target)) - (second (lower-manifest-entry second system - #:target - target))) - (if (string=? (manifest-entry-item first) - (manifest-entry-item second)) - (return result) - (raise (condition - (&profile-collision-error - (entry first) - (conflict second))))))) - (#f ;no conflict - (return result)))) + (lambda (entries result) + (match entries + ((first second) + (if (string=? (manifest-entry-item first) + (manifest-entry-item second)) + (return result) + (raise (condition + (&profile-collision-error + (entry first) + (conflict second)))))))) #t - (manifest-transitive-entries manifest)))) + lst))) (define* (package->manifest-entry package #:optional (output "out") #:key (parent (delay #f)) @@ -1372,26 +1427,38 @@ the entries in MANIFEST." #~(begin (use-modules (guix man-db) (guix build utils) + (ice-9 threads) (srfi srfi-1) (srfi srfi-19)) + (define (print-string msg) + (display msg) + (force-output)) + + (define-syntax-rule (print fmt args ...) + ;; Build up the string and display it at once. + (print-string (format #f fmt args ...))) + + (define (compute-entry directory count total) + (print "\r[~3d/~3d] building list of man-db entries..." + count total) + (let ((man (string-append directory "/share/man"))) + (if (directory-exists? man) + (mandb-entries man) + '()))) + (define (compute-entries) ;; This is the most expensive part (I/O and CPU, due to ;; decompression), so report progress as we traverse INPUTS. - (let* ((inputs '#$(manifest-inputs manifest)) - (total (length inputs))) - (append-map (lambda (directory count) - (format #t "\r[~3d/~3d] building list of \ -man-db entries..." - count total) - (force-output) - (let ((man (string-append directory - "/share/man"))) - (if (directory-exists? man) - (mandb-entries man) - '()))) - inputs - (iota total 1)))) + ;; Cap at 4 threads because we don't see any speedup beyond that + ;; on an SSD laptop. + (let* ((inputs '#$(manifest-inputs manifest)) + (total (length inputs)) + (threads (min (parallel-job-count) 4))) + (concatenate + (n-par-map threads compute-entry inputs + (iota total 1) + (make-list total total))))) (define man-directory (string-append #$output "/share/man")) @@ -1489,6 +1556,7 @@ MANIFEST." (define* (profile-derivation manifest #:key + (name "profile") (hooks %default-profile-hooks) (locales? #t) (allow-collisions? #f) @@ -1521,10 +1589,9 @@ are cross-built for TARGET." #:target target))) (extras (if (null? (manifest-entries manifest)) (return '()) - (mapm %store-monad - (lambda (hook) - (hook manifest)) - hooks)))) + (mapm/accumulate-builds (lambda (hook) + (hook manifest)) + hooks)))) (define inputs (append (filter-map (lambda (drv) (and (derivation? drv) @@ -1577,7 +1644,7 @@ are cross-built for TARGET." #:manifest '#$(manifest->gexp manifest) #:search-paths search-paths)))) - (gexp->derivation "profile" builder + (gexp->derivation name builder #:system system #:target target @@ -1598,6 +1665,33 @@ are cross-built for TARGET." . ,(length (manifest-entries manifest)))))))) +;; Declarative profile. +(define-record-type* <profile> profile make-profile + profile? + (name profile-name (default "profile")) ;string + (content profile-content) ;<manifest> + (hooks profile-hooks ;list of procedures + (default %default-profile-hooks)) + (locales? profile-locales? ;Boolean + (default #t)) + (allow-collisions? profile-allow-collisions? ;Boolean + (default #f)) + (relative-symlinks? profile-relative-symlinks? ;Boolean + (default #f))) + +(define-gexp-compiler (profile-compiler (profile <profile>) system target) + "Compile PROFILE to a derivation." + (match profile + (($ <profile> name manifest hooks + locales? allow-collisions? relative-symlinks?) + (profile-derivation manifest + #:name name + #:hooks hooks + #:locales? locales? + #:allow-collisions? allow-collisions? + #:relative-symlinks? relative-symlinks? + #:system system #:target target)))) + (define* (profile-search-paths profile #:optional (manifest (profile-manifest profile)) #:key (getenv (const #f))) |