Merge branch 'master' into core-updates

11 files changed, 642 insertions, 127 deletions

diff --git a/guix/config.scm.in b/guix/config.scm.in
index 8f2c4abd8e..dfe5fe0dbf 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@
 
             %store-directory
             %state-directory
+            %store-database-directory
             %config-directory
             %guix-register-program
 
@@ -80,6 +82,10 @@
   (or (getenv "NIX_STATE_DIR")
       (string-append %localstatedir "/guix")))
 
+(define %store-database-directory
+  (or (and=> (getenv "NIX_DB_DIR") canonicalize-path)
+      (string-append %state-directory "/db")))
+
 (define %config-directory
   ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'.
   (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
diff --git a/guix/docker.scm b/guix/docker.scm
index a75534c33b..b869901599 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -26,6 +26,7 @@
                           delete-file-recursively
                           with-directory-excursion
                           invoke))
+  #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module ((texinfo string-utils)
@@ -34,9 +35,6 @@
   #:use-module (ice-9 match)
   #:export (build-docker-image))
 
-;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
-(module-use! (current-module) (resolve-interface '(json)))
-
 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
 (define docker-id
   (compose bytevector->base16-string sha256 string->utf8))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index c6d70e4e36..153b29bd42 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -33,6 +33,7 @@
   #:export (gexp
             gexp?
             with-imported-modules
+            with-extensions
 
             gexp-input
             gexp-input?
@@ -118,10 +119,11 @@
 
 ;; "G expressions".
 (define-record-type <gexp>
-  (make-gexp references modules proc)
+  (make-gexp references modules extensions proc)
   gexp?
   (references gexp-references)                    ;list of <gexp-input>
   (modules    gexp-self-modules)                  ;list of module names
+  (extensions gexp-self-extensions)               ;list of lowerable things
   (proc       gexp-proc))                         ;procedure
 
 (define (write-gexp gexp port)
@@ -492,19 +494,20 @@ whether this should be considered a \"native\" input or not."
 
 (set-record-type-printer! <gexp-output> write-gexp-output)
 
-(define (gexp-modules gexp)
-  "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
-false, meaning that GEXP is a plain Scheme object, return the empty list."
+(define (gexp-attribute gexp self-attribute)
+  "Recurse on GEXP and the expressions it refers to, summing the items
+returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
   (if (gexp? gexp)
       (delete-duplicates
-       (append (gexp-self-modules gexp)
+       (append (self-attribute gexp)
                (append-map (match-lambda
                              (($ <gexp-input> (? gexp? exp))
-                              (gexp-modules exp))
+                              (gexp-attribute exp self-attribute))
                              (($ <gexp-input> (lst ...))
                               (append-map (lambda (item)
                                             (if (gexp? item)
-                                                (gexp-modules item)
+                                                (gexp-attribute item
+                                                                self-attribute)
                                                 '()))
                                           lst))
                              (_
@@ -512,6 +515,17 @@ false, meaning that GEXP is a plain Scheme object, return the empty list."
                            (gexp-references gexp))))
       '()))                                       ;plain Scheme data type
 
+(define (gexp-modules gexp)
+  "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
+false, meaning that GEXP is a plain Scheme object, return the empty list."
+  (gexp-attribute gexp gexp-self-modules))
+
+(define (gexp-extensions gexp)
+  "Return the list of Guile extensions (packages) GEXP relies on.  If (gexp?
+GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
+list."
+  (gexp-attribute gexp gexp-self-extensions))
+
 (define* (lower-inputs inputs
                        #:key system target)
   "Turn any package from INPUTS into a derivation for SYSTEM; return the
@@ -577,6 +591,7 @@ names and file names suitable for the #:allowed-references argument to
                            (modules '())
                            (module-path %load-path)
                            (guile-for-build (%guile-for-build))
+                           (effective-version "2.2")
                            (graft? (%graft?))
                            references-graphs
                            allowed-references disallowed-references
@@ -595,6 +610,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store,
 compiled, and made available in the load path during the execution of
 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 
+EFFECTIVE-VERSION determines the string to use when adding extensions of
+EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
+
 GRAFT? determines whether packages referred to by EXP should be grafted when
 applicable.
 
@@ -630,7 +648,7 @@ The other arguments are as for 'derivation'."
   (define (graphs-file-names graphs)
     ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
     (map (match-lambda
-          ;; TODO: Remove 'derivation?' special cases.
+           ;; TODO: Remove 'derivation?' special cases.
            ((file-name (? derivation? drv))
             (cons file-name (derivation->output-path drv)))
            ((file-name (? derivation? drv) sub-drv)
@@ -639,7 +657,13 @@ The other arguments are as for 'derivation'."
             (cons file-name thing)))
          graphs))
 
-  (mlet* %store-monad (;; The following binding forces '%current-system' and
+  (define (extension-flags extension)
+    `("-L" ,(string-append (derivation->output-path extension)
+                           "/share/guile/site/" effective-version)
+      "-C" ,(string-append (derivation->output-path extension)
+                           "/lib/guile/" effective-version "/site-ccache")))
+
+  (mlet* %store-monad ( ;; The following binding forces '%current-system' and
                        ;; '%current-target-system' to be looked up at >>=
                        ;; time.
                        (graft?    (set-grafting graft?))
@@ -660,6 +684,11 @@ The other arguments are as for 'derivation'."
                                              #:target target))
                        (builder  (text-file script-name
                                             (object->string sexp)))
+                       (extensions -> (gexp-extensions exp))
+                       (exts     (mapm %store-monad
+                                       (lambda (obj)
+                                         (lower-object obj system))
+                                       extensions))
                        (modules  (if (pair? %modules)
                                      (imported-modules %modules
                                                        #:system system
@@ -672,6 +701,7 @@ The other arguments are as for 'derivation'."
                                      (compiled-modules %modules
                                                        #:system system
                                                        #:module-path module-path
+                                                       #:extensions extensions
                                                        #:guile guile-for-build
                                                        #:deprecation-warnings
                                                        deprecation-warnings)
@@ -704,6 +734,7 @@ The other arguments are as for 'derivation'."
                               `("-L" ,(derivation->output-path modules)
                                 "-C" ,(derivation->output-path compiled))
                               '())
+                        ,@(append-map extension-flags exts)
                         ,builder)
                       #:outputs outputs
                       #:env-vars env-vars
@@ -713,6 +744,7 @@ The other arguments are as for 'derivation'."
                                  ,@(if modules
                                        `((,modules) (,compiled) ,@inputs)
                                        inputs)
+                                 ,@(map list exts)
                                  ,@(match graphs
                                      (((_ . inputs) ...) inputs)
                                      (_ '())))
@@ -861,6 +893,17 @@ environment."
                          (identifier-syntax modules)))
     body ...))
 
+(define-syntax-parameter current-imported-extensions
+  ;; Current list of extensions.
+  (identifier-syntax '()))
+
+(define-syntax-rule (with-extensions extensions body ...)
+  "Mark the gexps defined in BODY... as requiring EXTENSIONS in their
+execution environment."
+  (syntax-parameterize ((current-imported-extensions
+                         (identifier-syntax extensions)))
+    body ...))
+
 (define-syntax gexp
   (lambda (s)
     (define (collect-escapes exp)
@@ -957,6 +1000,7 @@ environment."
               (refs    (map escape->ref escapes)))
          #`(make-gexp (list #,@refs)
                       current-imported-modules
+                      current-imported-extensions
                       (lambda #,formals
                         #,sexp)))))))
 
@@ -1071,12 +1115,21 @@ last one is created from the given <scheme-file> object."
                            (system (%current-system))
                            (guile (%guile-for-build))
                            (module-path %load-path)
+                           (extensions '())
                            (deprecation-warnings #f))
   "Return a derivation that builds a tree containing the `.go' files
 corresponding to MODULES.  All the MODULES are built in a context where
 they can refer to each other."
   (define total (length modules))
 
+  (define build-utils-hack?
+    ;; To avoid a full rebuild, we limit the fix below to the case where
+    ;; MODULE-PATH is different from %LOAD-PATH.  This happens when building
+    ;; modules for 'compute-guix-derivation' upon 'guix pull'.  TODO: Make
+    ;; this unconditional on the next rebuild cycle.
+    (and (member '(guix build utils) modules)
+         (not (equal? module-path %load-path))))
+
   (mlet %store-monad ((modules (imported-modules modules
                                                  #:system system
                                                  #:guile guile
@@ -1122,7 +1175,47 @@ they can refer to each other."
          (setvbuf (current-output-port)
                   (cond-expand (guile-2.2 'line) (else _IOLBF)))
 
+         (ungexp-splicing
+          (if build-utils-hack?
+              (gexp ((define mkdir-p
+                       ;; Capture 'mkdir-p'.
+                       (@ (guix build utils) mkdir-p))))
+              '()))
+
+         ;; Add EXTENSIONS to the search path.
+         ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle.
+         (ungexp-splicing
+          (if (null? extensions)
+              '()
+              (gexp ((set! %load-path
+                       (append (map (lambda (extension)
+                                      (string-append extension
+                                                     "/share/guile/site/"
+                                                     (effective-version)))
+                                    '((ungexp-native-splicing extensions)))
+                               %load-path))
+                     (set! %load-compiled-path
+                       (append (map (lambda (extension)
+                                      (string-append extension "/lib/guile/"
+                                                     (effective-version)
+                                                     "/site-ccache"))
+                                    '((ungexp-native-splicing extensions)))
+                               %load-compiled-path))))))
+
          (set! %load-path (cons (ungexp modules) %load-path))
+
+         (ungexp-splicing
+          (if build-utils-hack?
+              ;; Above we loaded our own (guix build utils) but now we may
+              ;; need to load a compile a different one.  Thus, force a
+              ;; reload.
+              (gexp ((let ((utils (ungexp
+                                   (file-append modules
+                                                "/guix/build/utils.scm"))))
+                       (when (file-exists? utils)
+                         (load utils)))))
+              '()))
+
          (mkdir (ungexp output))
          (chdir (ungexp modules))
          (process-directory "." (ungexp output) 0))))
@@ -1154,20 +1247,34 @@ they can refer to each other."
   (module-ref (resolve-interface '(gnu packages guile))
               'guile-2.2))
 
-(define* (load-path-expression modules #:optional (path %load-path))
+(define* (load-path-expression modules #:optional (path %load-path)
+                               #:key (extensions '()))
   "Return as a monadic value a gexp that sets '%load-path' and
 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
 are searched for in PATH."
   (mlet %store-monad ((modules  (imported-modules modules
                                                   #:module-path path))
                       (compiled (compiled-modules modules
+                                                  #:extensions extensions
                                                   #:module-path path)))
     (return (gexp (eval-when (expand load eval)
                     (set! %load-path
-                      (cons (ungexp modules) %load-path))
+                      (cons (ungexp modules)
+                            (append (map (lambda (extension)
+                                           (string-append extension
+                                                          "/share/guile/site/"
+                                                          (effective-version)))
+                                         '((ungexp-native-splicing extensions)))
+                                    %load-path)))
                     (set! %load-compiled-path
                       (cons (ungexp compiled)
-                            %load-compiled-path)))))))
+                            (append (map (lambda (extension)
+                                           (string-append extension
+                                                          "/lib/guile/"
+                                                          (effective-version)
+                                                          "/site-ccache"))
+                                         '((ungexp-native-splicing extensions)))
+                                    %load-compiled-path))))))))
 
 (define* (gexp->script name exp
                        #:key (guile (default-guile))
@@ -1176,7 +1283,9 @@ are searched for in PATH."
 imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
   (mlet %store-monad ((set-load-path
                        (load-path-expression (gexp-modules exp)
-                                             module-path)))
+                                             module-path
+                                             #:extensions
+                                             (gexp-extensions exp))))
     (gexp->derivation name
                       (gexp
                        (call-with-output-file (ungexp output)
@@ -1205,35 +1314,38 @@ the resulting file.
 When SET-LOAD-PATH? is true, emit code in the resulting file to set
 '%load-path' and '%load-compiled-path' to honor EXP's imported modules.
 Lookup EXP's modules in MODULE-PATH."
-  (match (if set-load-path? (gexp-modules exp) '())
-    (()                                           ;zero modules
-     (gexp->derivation name
-                       (gexp
-                        (call-with-output-file (ungexp output)
-                          (lambda (port)
-                            (for-each (lambda (exp)
-                                        (write exp port))
-                                      '(ungexp (if splice?
-                                                   exp
-                                                   (gexp ((ungexp exp)))))))))
-                       #:local-build? #t
-                       #:substitutable? #f))
-    ((modules ...)
-     (mlet %store-monad ((set-load-path (load-path-expression modules
-                                                              module-path)))
-       (gexp->derivation name
-                         (gexp
-                          (call-with-output-file (ungexp output)
-                            (lambda (port)
-                              (write '(ungexp set-load-path) port)
-                              (for-each (lambda (exp)
-                                          (write exp port))
-                                        '(ungexp (if splice?
-                                                     exp
-                                                     (gexp ((ungexp exp)))))))))
-                         #:module-path module-path
-                         #:local-build? #t
-                         #:substitutable? #f)))))
+  (define modules (gexp-modules exp))
+  (define extensions (gexp-extensions exp))
+
+  (if (or (not set-load-path?)
+          (and (null? modules) (null? extensions)))
+      (gexp->derivation name
+                        (gexp
+                         (call-with-output-file (ungexp output)
+                           (lambda (port)
+                             (for-each (lambda (exp)
+                                         (write exp port))
+                                       '(ungexp (if splice?
+                                                    exp
+                                                    (gexp ((ungexp exp)))))))))
+                        #:local-build? #t
+                        #:substitutable? #f)
+      (mlet %store-monad ((set-load-path
+                           (load-path-expression modules module-path
+                                                 #:extensions extensions)))
+        (gexp->derivation name
+                          (gexp
+                           (call-with-output-file (ungexp output)
+                             (lambda (port)
+                               (write '(ungexp set-load-path) port)
+                               (for-each (lambda (exp)
+                                           (write exp port))
+                                         '(ungexp (if splice?
+                                                      exp
+                                                      (gexp ((ungexp exp)))))))))
+                          #:module-path module-path
+                          #:local-build? #t
+                          #:substitutable? #f))))
 
 (define* (text-file* name #:rest text)
   "Return as a monadic value a derivation that builds a text file containing
diff --git a/guix/man-db.scm b/guix/man-db.scm
index 732aef1083..4cef874f8b 100644
--- a/guix/man-db.scm
+++ b/guix/man-db.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +19,7 @@
 (define-module (guix man-db)
   #:use-module (guix zlib)
   #:use-module ((guix build utils) #:select (find-files))
+  #:use-module (gdbm)                             ;gdbm-ffi
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -44,9 +45,6 @@
 ;;;
 ;;; Code:
 
-;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co.
-(module-autoload! (current-module) '(gdbm) '(gdbm-open GDBM_WRCREAT))
-
 (define-record-type <mandb-entry>
   (mandb-entry file-name name section synopsis kind)
   mandb-entry?
diff --git a/guix/profiles.scm b/guix/profiles.scm
index fd7e5b922c..9bddf88162 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1196,41 +1196,39 @@ the entries in MANIFEST."
 
   (define build
     (with-imported-modules modules
-      #~(begin
-          (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/"
-                                           (effective-version)))
-
-          (use-modules (guix man-db)
-                       (guix build utils)
-                       (srfi srfi-1)
-                       (srfi srfi-19))
-
-          (define (compute-entries)
-            (append-map (lambda (directory)
-                          (let ((man (string-append directory "/share/man")))
-                            (if (directory-exists? man)
-                                (mandb-entries man)
-                                '())))
-                        '#$(manifest-inputs manifest)))
-
-          (define man-directory
-            (string-append #$output "/share/man"))
-
-          (mkdir-p man-directory)
-
-          (format #t "Creating manual page database...~%")
-          (force-output)
-          (let* ((start    (current-time))
-                 (entries  (compute-entries))
-                 (_        (write-mandb-database (string-append man-directory
-                                                                "/index.db")
-                                                 entries))
-                 (duration (time-difference (current-time) start)))
-            (format #t "~a entries processed in ~,1f s~%"
-                    (length entries)
-                    (+ (time-second duration)
-                       (* (time-nanosecond duration) (expt 10 -9))))
-            (force-output)))))
+      (with-extensions (list gdbm-ffi)            ;for (guix man-db)
+        #~(begin
+            (use-modules (guix man-db)
+                         (guix build utils)
+                         (srfi srfi-1)
+                         (srfi srfi-19))
+
+            (define (compute-entries)
+              (append-map (lambda (directory)
+                            (let ((man (string-append directory "/share/man")))
+                              (if (directory-exists? man)
+                                  (mandb-entries man)
+                                  '())))
+                          '#$(manifest-inputs manifest)))
+
+            (define man-directory
+              (string-append #$output "/share/man"))
+
+            (mkdir-p man-directory)
+
+            (format #t "Creating manual page database...~%")
+            (force-output)
+            (let* ((start    (current-time))
+                   (entries  (compute-entries))
+                   (_        (write-mandb-database (string-append man-directory
+                                                                  "/index.db")
+                                                   entries))
+                   (duration (time-difference (current-time) start)))
+              (format #t "~a entries processed in ~,1f s~%"
+                      (length entries)
+                      (+ (time-second duration)
+                         (* (time-nanosecond duration) (expt 10 -9))))
+              (force-output))))))
 
   (gexp->derivation "manual-database" build
 
diff --git a/guix/records.scm b/guix/records.scm
index c71cfcfe32..da3ecdaaf8 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -63,22 +63,25 @@
 (set-exception-printer! 'record-abi-mismatch-error
                         print-record-abi-mismatch-error)
 
-(define (current-abi-identifier type)
-  "Return an identifier unhygienically derived from TYPE for use as its
+(eval-when (expand load eval)
+  ;; The procedures below are needed both at run time and at expansion time.
+
+  (define (current-abi-identifier type)
+    "Return an identifier unhygienically derived from TYPE for use as its
 \"current ABI\" variable."
-  (let ((type-name (syntax->datum type)))
-    (datum->syntax
-     type
-     (string->symbol
-      (string-append "% " (symbol->string type-name)
-                     " abi-cookie")))))
-
-(define (abi-check type cookie)
-  "Return syntax that checks that the current \"application binary
+    (let ((type-name (syntax->datum type)))
+      (datum->syntax
+       type
+       (string->symbol
+        (string-append "% " (symbol->string type-name)
+                       " abi-cookie")))))
+
+  (define (abi-check type cookie)
+    "Return syntax that checks that the current \"application binary
 interface\" (ABI) for TYPE is equal to COOKIE."
-  (with-syntax ((current-abi (current-abi-identifier type)))
-    #`(unless (eq? current-abi #,cookie)
-        (throw 'record-abi-mismatch-error #,type))))
+    (with-syntax ((current-abi (current-abi-identifier type)))
+      #`(unless (eq? current-abi #,cookie)
+          (throw 'record-abi-mismatch-error #,type)))))
 
 (define-syntax make-syntactic-constructor
   (syntax-rules ()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 35b8a7e729..76729d8e10 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -340,28 +340,25 @@ the image."
         guile-json))
 
   (define build
-    (with-imported-modules `(,@(source-module-closure '((guix docker))
-                                                      #:select? not-config?)
-                             (guix build store-copy)
-                             ((guix config) => ,config))
-      #~(begin
-          ;; Guile-JSON is required by (guix docker).
-          (add-to-load-path
-           (string-append #+json "/share/guile/site/"
-                          (effective-version)))
-
-          (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
-
-          (setenv "PATH" (string-append #$archiver "/bin"))
-
-          (build-docker-image #$output
-                              (call-with-input-file "profile"
-                                read-reference-graph)
-                              #$profile
-                              #:system (or #$target (utsname:machine (uname)))
-                              #:symlinks '#$symlinks
-                              #:compressor '#$(compressor-command compressor)
-                              #:creation-time (make-time time-utc 0 1)))))
+    ;; Guile-JSON is required by (guix docker).
+    (with-extensions (list json)
+      (with-imported-modules `(,@(source-module-closure '((guix docker))
+                                                        #:select? not-config?)
+                               (guix build store-copy)
+                               ((guix config) => ,config))
+        #~(begin
+            (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
+
+            (setenv "PATH" (string-append #$archiver "/bin"))
+
+            (build-docker-image #$output
+                                (call-with-input-file "profile"
+                                  read-reference-graph)
+                                #$profile
+                                #:system (or #$target (utsname:machine (uname)))
+                                #:symlinks '#$symlinks
+                                #:compressor '#$(compressor-command compressor)
+                                #:creation-time (make-time time-utc 0 1))))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 5d0df14924..766cab1aad 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -393,9 +393,11 @@ it atomically, and then run OS's activation script."
                   "~Y-~m-~d ~H:~M")))
 
 (define* (profile-boot-parameters #:optional (profile %system-profile)
-                                  (numbers (generation-numbers profile)))
-  "Return a list of 'boot-parameters' for the generations of PROFILE specified by
-NUMBERS, which is a list of generation numbers."
+                                  (numbers
+                                   (reverse (generation-numbers profile))))
+  "Return a list of 'boot-parameters' for the generations of PROFILE specified
+by NUMBERS, which is a list of generation numbers. The list is ordered from
+the most recent to the oldest profiles."
   (define (system->boot-parameters system number time)
     (unless-file-not-found
      (let* ((params           (read-boot-parameters-file system))
diff --git a/guix/self.scm b/guix/self.scm
index 4378a3dee5..3503fbda43 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -82,6 +82,8 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
       ("guile-json" (ref '(gnu packages guile) 'guile-json))
       ("guile-ssh"  (ref '(gnu packages ssh)   'guile-ssh))
       ("guile-git"  (ref '(gnu packages guile) 'guile-git))
+      ("guile-gdbm-ffi" (ref '(gnu packages guile) 'guile-gdbm-ffi))
+      ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
       ("libgcrypt"  (ref '(gnu packages gnupg) 'libgcrypt))
       ("zlib"       (ref '(gnu packages compression) 'zlib))
       ("gzip"       (ref '(gnu packages compression) 'gzip))
@@ -92,6 +94,8 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
       ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json))
       ("guile2.0-ssh"  (ref '(gnu packages ssh) 'guile2.0-ssh))
       ("guile2.0-git"  (ref '(gnu packages guile) 'guile2.0-git))
+      ("guile2.0-gdbm-ffi" (ref '(gnu packages guile) 'guile2.0-gdbm-ffi))
+      ;; XXX: No "guile2.0-sqlite3".
       (_               #f))))                     ;no such package
 
 
@@ -215,12 +219,23 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
                        "guile-git"
                        "guile2.0-git"))
 
+  (define guile-gdbm-ffi
+    (package-for-guile guile-version
+                       "guile-gdbm-ffi"
+                       "guile2.0-gdbm-ffi"))
+
+
+  (define guile-sqlite3
+    (package-for-guile guile-version
+                       "guile-sqlite3"
+                       "guile2.0-sqlite3"))
 
   (define dependencies
     (match (append-map (lambda (package)
                          (cons (list "x" package)
-                               (package-transitive-inputs package)))
-                       (list guile-git guile-json guile-ssh))
+                               (package-transitive-propagated-inputs package)))
+                       (list guile-git guile-json guile-ssh
+                             guile-gdbm-ffi guile-sqlite3))
       (((labels packages _ ...) ...)
        packages)))
 
@@ -573,7 +588,11 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
                  `(#:local-build? #f              ;allow substitutes
 
                    ;; Don't annoy people about _IONBF deprecation.
-                   #:env-vars (("GUILE_WARN_DEPRECATED" . "no")))))
+                   ;; Initialize 'terminal-width' in (system repl debug)
+                   ;; to a large-enough value to make backtrace more
+                   ;; verbose.
+                   #:env-vars (("GUILE_WARN_DEPRECATED" . "no")
+                               ("COLUMNS" . "200")))))
 
 
 ;;;
diff --git a/guix/store/database.scm b/guix/store/database.scm
new file mode 100644
index 0000000000..3623c0e7a0
--- /dev/null
+++ b/guix/store/database.scm
@@ -0,0 +1,234 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix store database)
+  #:use-module (sqlite3)
+  #:use-module (guix config)
+  #:use-module (guix serialization)
+  #:use-module (guix store deduplication)
+  #:use-module (guix base16)
+  #:use-module (guix build syscalls)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 match)
+  #:export (sqlite-register
+            register-path
+            reset-timestamps))
+
+;;; Code for working with the store database directly.
+
+
+(define-syntax-rule (with-database file db exp ...)
+  "Open DB from FILE and close it when the dynamic extent of EXP... is left."
+  (let ((db (sqlite-open file)))
+    (dynamic-wind noop
+                  (lambda ()
+                    exp ...)
+                  (lambda ()
+                    (sqlite-close db)))))
+
+(define (last-insert-row-id db)
+  ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
+  ;; Work around that.
+  (let* ((stmt   (sqlite-prepare db "SELECT last_insert_rowid();"
+                               #:cache? #t))
+         (result (sqlite-fold cons '() stmt)))
+    (sqlite-finalize stmt)
+    (match result
+      ((#(id)) id)
+      (_ #f))))
+
+(define path-id-sql
+  "SELECT id FROM ValidPaths WHERE path = :path")
+
+(define* (path-id db path)
+  "If PATH exists in the 'ValidPaths' table, return its numerical
+identifier.  Otherwise, return #f."
+  (let ((stmt (sqlite-prepare db path-id-sql #:cache? #t)))
+    (sqlite-bind-arguments stmt #:path path)
+    (let ((result (sqlite-fold cons '() stmt)))
+      (sqlite-finalize stmt)
+      (match result
+        ((#(id) . _) id)
+        (_ #f)))))
+
+(define update-sql
+  "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver =
+:deriver, narSize = :size WHERE id = :id")
+
+(define insert-sql
+  "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize)
+VALUES (:path, :hash, :time, :deriver, :size)")
+
+(define* (update-or-insert db #:key path deriver hash nar-size time)
+  "The classic update-if-exists and insert-if-doesn't feature that sqlite
+doesn't exactly have... they've got something close, but it involves deleting
+and re-inserting instead of updating, which causes problems with foreign keys,
+of course. Returns the row id of the row that was modified or inserted."
+  (let ((id (path-id db path)))
+    (if id
+        (let ((stmt (sqlite-prepare db update-sql #:cache? #t)))
+          (sqlite-bind-arguments stmt #:id id
+                                 #:path path #:deriver deriver
+                                 #:hash hash #:size nar-size #:time time)
+          (sqlite-fold cons '() stmt)
+          (sqlite-finalize stmt)
+          (last-insert-row-id db))
+        (let ((stmt (sqlite-prepare db insert-sql #:cache? #t)))
+          (sqlite-bind-arguments stmt
+                                 #:path path #:deriver deriver
+                                 #:hash hash #:size nar-size #:time time)
+          (sqlite-fold cons '() stmt)             ;execute it
+          (sqlite-finalize stmt)
+          (last-insert-row-id db)))))
+
+(define add-reference-sql
+  "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id
+FROM ValidPaths WHERE path = :reference")
+
+(define (add-references db referrer references)
+  "REFERRER is the id of the referring store item, REFERENCES is a list
+containing store items being referred to.  Note that all of the store items in
+REFERENCES must already be registered."
+  (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t)))
+    (for-each (lambda (reference)
+                (sqlite-reset stmt)
+                (sqlite-bind-arguments stmt #:referrer referrer
+                                       #:reference reference)
+                (sqlite-fold cons '() stmt)       ;execute it
+                (sqlite-finalize stmt)
+                (last-insert-row-id db))
+              references)))
+
+;; XXX figure out caching of statement and database objects... later
+(define* (sqlite-register #:key db-file path (references '())
+                          deriver hash nar-size)
+  "Registers this stuff in a database specified by DB-FILE. PATH is the string
+path of some store item, REFERENCES is a list of string paths which the store
+item PATH refers to (they need to be already registered!), DERIVER is a string
+path of the derivation that created the store item PATH, HASH is the
+base16-encoded sha256 hash of the store item denoted by PATH (prefixed with
+\"sha256:\") after being converted to nar form, and nar-size is the size in
+bytes of the store item denoted by PATH after being converted to nar form."
+  (with-database db-file db
+    (let ((id (update-or-insert db #:path path
+                                #:deriver deriver
+                                #:hash hash
+                                #:nar-size nar-size
+                                #:time (time-second (current-time time-utc)))))
+      (add-references db id references))))
+
+
+;;;
+;;; High-level interface.
+;;;
+
+;; TODO: Factorize with that in (gnu build install).
+(define (reset-timestamps file)
+  "Reset the modification time on FILE and on all the files it contains, if
+it's a directory."
+  (let loop ((file file)
+             (type (stat:type (lstat file))))
+    (case type
+      ((directory)
+       (utime file 0 0 0 0)
+       (let ((parent file))
+         (for-each (match-lambda
+                     (("." . _) #f)
+                     ((".." . _) #f)
+                     ((file . properties)
+                      (let ((file (string-append parent "/" file)))
+                        (loop file
+                              (match (assoc-ref properties 'type)
+                                ((or 'unknown #f)
+                                 (stat:type (lstat file)))
+                                (type type))))))
+                   (scandir* parent))))
+      ((symlink)
+       ;; FIXME: Implement bindings for 'futime' to reset the timestamps on
+       ;; symlinks.
+       #f)
+      (else
+       (utime file 0 0 0 0)))))
+
+;; TODO: make this canonicalize store items that are registered. This involves
+;; setting permissions and timestamps, I think. Also, run a "deduplication
+;; pass", whatever that involves. Also, handle databases not existing yet
+;; (what should the default behavior be?  Figuring out how the C++ stuff
+;; currently does it sounds like a lot of grepping for global
+;; variables...). Also, return #t on success like the documentation says we
+;; should.
+
+(define* (register-path path
+                        #:key (references '()) deriver prefix
+                        state-directory (deduplicate? #t))
+  ;; Priority for options: first what is given, then environment variables,
+  ;; then defaults. %state-directory, %store-directory, and
+  ;; %store-database-directory already handle the "environment variables /
+  ;; defaults" question, so we only need to choose between what is given and
+  ;; those.
+  "Register PATH as a valid store file, with REFERENCES as its list of
+references, and DERIVER as its deriver (.drv that led to it.)  If PREFIX is
+given, it must be the name of the directory containing the new store to
+initialize; if STATE-DIRECTORY is given, it must be a string containing the
+absolute file name to the state directory of the store being initialized.
+Return #t on success.
+
+Use with care as it directly modifies the store!  This is primarily meant to
+be used internally by the daemon's build hook."
+  (let* ((db-dir (cond
+                  (state-directory
+                   (string-append state-directory "/db"))
+                  (prefix
+                   ;; If prefix is specified, the value of NIX_STATE_DIR
+                   ;; (which affects %state-directory) isn't supposed to
+                   ;; affect db-dir, only the compile-time-customized
+                   ;; default should.
+                   (string-append prefix %localstatedir "/guix/db"))
+                  (else
+                   %store-database-directory)))
+         (store-dir (if prefix
+                        ;; same situation as above
+                        (string-append prefix %storedir)
+                        %store-directory))
+         (to-register (if prefix
+                          (string-append %storedir "/" (basename path))
+                          ;; note: we assume here that if path is, for
+                          ;; example, /foo/bar/gnu/store/thing.txt and prefix
+                          ;; isn't given, then an environment variable has
+                          ;; been used to change the store directory to
+                          ;; /foo/bar/gnu/store, since otherwise real-path
+                          ;; would end up being /gnu/store/thing.txt, which is
+                          ;; probably not the right file in this case.
+                          path))
+         (real-path (string-append store-dir "/" (basename path))))
+    (let-values (((hash nar-size)
+                  (nar-sha256 real-path)))
+      (reset-timestamps real-path)
+      (sqlite-register
+       #:db-file (string-append db-dir "/db.sqlite")
+       #:path to-register
+       #:references references
+       #:deriver deriver
+       #:hash (string-append "sha256:"
+                             (bytevector->base16-string hash))
+       #:nar-size nar-size)
+
+      (when deduplicate?
+        (deduplicate real-path hash #:store store-dir)))))
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
new file mode 100644
index 0000000000..4b4ac01f64
--- /dev/null
+++ b/guix/store/deduplication.scm
@@ -0,0 +1,148 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; This houses stuff we do to files when they arrive at the store - resetting
+;;; timestamps, deduplicating, etc.
+
+(define-module (guix store deduplication)
+  #:use-module (guix hash)
+  #:use-module (guix build utils)
+  #:use-module (guix base16)
+  #:use-module (srfi srfi-11)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 ftw)
+  #:use-module (guix serialization)
+  #:export (nar-sha256
+            deduplicate))
+
+;; Would it be better to just make WRITE-FILE give size as well? I question
+;; the general utility of this approach.
+(define (counting-wrapper-port output-port)
+  "Some custom ports don't implement GET-POSITION at all. But if we want to
+figure out how many bytes are being written, we will want to use that. So this
+makes a wrapper around a port which implements GET-POSITION."
+  (let ((byte-count 0))
+    (make-custom-binary-output-port "counting-wrapper"
+                                    (lambda (bytes offset count)
+                                      (set! byte-count
+                                        (+ byte-count count))
+                                      (put-bytevector output-port bytes
+                                                      offset count)
+                                      count)
+                                    (lambda ()
+                                      byte-count)
+                                    #f
+                                    (lambda ()
+                                      (close-port output-port)))))
+
+(define (nar-sha256 file)
+  "Gives the sha256 hash of a file and the size of the file in nar form."
+  (let-values (((port get-hash) (open-sha256-port)))
+    (let ((wrapper (counting-wrapper-port port)))
+      (write-file file wrapper)
+      (force-output wrapper)
+      (force-output port)
+      (let ((hash (get-hash))
+            (size (port-position wrapper)))
+        (close-port wrapper)
+        (values hash size)))))
+
+(define (tempname-in directory)
+  "Gives an unused temporary name under DIRECTORY. Not guaranteed to still be
+unused by the time you create anything with that name, but a good shot."
+  (let ((const-part (string-append directory "/.tmp-link-"
+                                   (number->string (getpid)))))
+    (let try ((guess-part
+               (number->string (random most-positive-fixnum) 16)))
+      (if (file-exists? (string-append const-part "-" guess-part))
+          (try (number->string (random most-positive-fixnum) 16))
+          (string-append const-part "-" guess-part)))))
+
+(define* (get-temp-link target #:optional (link-prefix (dirname target)))
+  "Like mkstemp!, but instead of creating a new file and giving you the name,
+it creates a new hardlink to TARGET and gives you the name. Since
+cross-filesystem hardlinks don't work, the temp link must be created on the
+same filesystem - where in that filesystem it is can be controlled by
+LINK-PREFIX."
+  (let try ((tempname (tempname-in link-prefix)))
+    (catch 'system-error
+      (lambda ()
+        (link target tempname)
+        tempname)
+      (lambda (args)
+        (if (= (system-error-errno args) EEXIST)
+            (try (tempname-in link-prefix))
+            (throw 'system-error args))))))
+
+;; There are 3 main kinds of errors we can get from hardlinking: "Too many
+;; things link to this" (EMLINK), "this link already exists" (EEXIST), and
+;; "can't fit more stuff in this directory" (ENOSPC).
+
+(define (replace-with-link target to-replace)
+  "Atomically replace the file TO-REPLACE with a link to TARGET.  Note: TARGET
+and TO-REPLACE must be on the same file system."
+  (let ((temp-link (get-temp-link target (dirname to-replace))))
+    (rename-file temp-link to-replace)))
+
+(define-syntax-rule (false-if-system-error (errors ...) exp ...)
+  "Given ERRORS, a list of system error codes to ignore, evaluates EXP... and
+return #f if any of the system error codes in the given list are thrown."
+  (catch 'system-error
+    (lambda ()
+      exp ...)
+    (lambda args
+      (if (member (system-error-errno args) (list errors ...))
+          #f
+          (apply throw args)))))
+
+(define* (deduplicate path hash #:key (store %store-directory))
+  "Check if a store item with sha256 hash HASH already exists.  If so,
+replace PATH with a hardlink to the already-existing one.  If not, register
+PATH so that future duplicates can hardlink to it.  PATH is assumed to be
+under STORE."
+  (let* ((links-directory (string-append store "/.links"))
+         (link-file       (string-append links-directory "/"
+                                         (bytevector->base16-string hash))))
+    (mkdir-p links-directory)
+    (if (file-is-directory? path)
+        ;; Can't hardlink directories, so hardlink their atoms.
+        (for-each (lambda (file)
+                    (unless (member file '("." ".."))
+                      (deduplicate file (nar-sha256 file)
+                                   #:store store)))
+                  (scandir path))
+        (if (file-exists? link-file)
+            (false-if-system-error (EMLINK)
+                                   (replace-with-link link-file path))
+            (catch 'system-error
+              (lambda ()
+                (link path link-file))
+              (lambda args
+                (let ((errno (system-error-errno args)))
+                  (cond ((= errno EEXIST)
+                         ;; Someone else put an entry for PATH in
+                         ;; LINKS-DIRECTORY before we could.  Let's use it.
+                         (false-if-system-error (EMLINK)
+                                                (replace-with-link path link-file)))
+                        ((= errno ENOSPC)
+                         ;; There's not enough room in the directory index for
+                         ;; more entries in .links, but that's fine: we can
+                         ;; just stop.
+                         #f)
+                        (else (apply throw args))))))))))