From e0b47290a704c954d00d86e0c120fe44946f29f9 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 19 Jun 2016 21:29:01 +0200
Subject: services: Add 'gc-root-service-type'.

* gnu/services.scm (gc-roots->system-entry): New procedure.
(gc-root-service-type): New variable.
---
 gnu/services.scm | 28 ++++++++++++++++++++++++++++
 1 file changed, 28 insertions(+)

(limited to 'gnu')

diff --git a/gnu/services.scm b/gnu/services.scm
index 9268c51dd8..50e76df818 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -73,6 +73,7 @@
             setuid-program-service-type
             profile-service-type
             firmware-service-type
+            gc-root-service-type
 
             %boot-service
             %activation-service
@@ -489,6 +490,33 @@ kernel."
                 (compose concatenate)
                 (extend append)))
 
+(define (gc-roots->system-entry roots)
+  "Return an entry in the system's output containing symlinks to ROOTS."
+  (mlet %store-monad ((entry (gexp->derivation
+                              "gc-roots"
+                              #~(let ((roots '#$roots))
+                                  (mkdir #$output)
+                                  (chdir #$output)
+                                  (for-each symlink
+                                            roots
+                                            (map number->string
+                                                 (iota (length roots))))))))
+    (return (if (null? roots)
+                '()
+                `(("gc-roots" ,entry))))))
+
+(define gc-root-service-type
+  ;; A service to associate extra garbage-collector roots to the system.  This
+  ;; is a simple hack that guarantees that the system retains references to
+  ;; the given list of roots.  Roots must be "lowerable" objects like
+  ;; packages, or derivations.
+  (service-type (name 'gc-roots)
+                (extensions
+                 (list (service-extension system-service-type
+                                          gc-roots->system-entry)))
+                (compose concatenate)
+                (extend append)))
+
 
 ;;;
 ;;; Service folding.
-- 
cgit 1.4.1