aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-build.in46
-rw-r--r--guix/store.scm8
2 files changed, 52 insertions, 2 deletions
diff --git a/guix-build.in b/guix-build.in
index bd32ce951e..7089a74731 100644
--- a/guix-build.in
+++ b/guix-build.in
@@ -101,6 +101,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
--no-substitutes build instead of resorting to pre-built substitutes"))
(display (_ "
-c, --cores=N allow the use of up to N CPU cores for the build"))
+ (display (_ "
+ -r, --root=FILE make FILE a symlink to the result, and register it
+ as a garbage collector root"))
(newline)
(display (_ "
-h, --help display this help and exit"))
@@ -151,7 +154,10 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(option '("no-substitutes") #f #f
(lambda (opt name arg result)
(alist-cons 'substitutes? #f
- (alist-delete 'substitutes? result))))))
+ (alist-delete 'substitutes? result))))
+ (option '(#\r "root") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'gc-root arg result)))))
;;;
@@ -168,6 +174,33 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(alist-cons 'argument arg result))
%default-options))
+ (define (register-root drv root)
+ ;; Register ROOT as an indirect GC root for DRV's outputs.
+ (let* ((root (string-append (canonicalize-path (dirname root))
+ "/" root))
+ (drv* (call-with-input-file drv read-derivation))
+ (outputs (derivation-outputs drv*))
+ (outputs* (map (compose derivation-output-path cdr) outputs)))
+ (catch 'system-error
+ (lambda ()
+ (match outputs*
+ ((output)
+ (symlink output root)
+ (add-indirect-root %store root))
+ ((outputs ...)
+ (fold (lambda (output count)
+ (let ((root (string-append root "-" (number->string count))))
+ (symlink output root)
+ (add-indirect-root %store root))
+ (+ 1 count))
+ 0
+ outputs))))
+ (lambda args
+ (format (current-error-port)
+ (_ "failed to create GC root `~a': ~a~%")
+ root (strerror (system-error-errno args)))
+ (exit 1)))))
+
(setlocale LC_ALL "")
(textdomain "guix")
(setvbuf (current-output-port) _IOLBF)
@@ -244,7 +277,16 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(derivation-path->output-path
d out-name)))
(derivation-outputs drv)))))
- drv)))))))
+ drv)
+ (let ((roots (filter-map (match-lambda
+ (('gc-root . root)
+ root)
+ (_ #f))
+ opts)))
+ (when roots
+ (for-each (cut register-root <> <>)
+ drv roots)
+ #t))))))))
;; Local Variables:
;; eval: (put 'guard 'scheme-indent-function 1)
diff --git a/guix/store.scm b/guix/store.scm
index 34421a11df..5ac98d80bb 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -49,6 +49,7 @@
add-text-to-store
add-to-store
build-derivations
+ add-indirect-root
current-build-output-port
@@ -419,6 +420,13 @@ again until #t is returned or an error is raised."
Return #t on success."
boolean)
+(define-operation (add-indirect-root (string file-name))
+ "Make FILE-NAME an indirect root for the garbage collector; FILE-NAME
+can be anywhere on the file system, but it must be an absolute file
+name--it is the caller's responsibility to ensure that it is an absolute
+file name. Return #t on success."
+ boolean)
+
;;;
;;; Store paths.