Merge branch 'master' into staging

5 files changed, 111 insertions, 49 deletions

diff --git a/guix/channels.scm b/guix/channels.scm
index 2c28dccbcb..826ee729ad 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -505,7 +505,7 @@ modules in the old ~/.config/guix/latest style."
                    ;; In the "old style", %SELF-BUILD-FILE would simply return a
                    ;; derivation that builds modules.  We have to infer what the
                    ;; dependencies of these modules were.
-                   (list guile-json guile-git guile-bytestructures
+                   (list guile-json-3 guile-git guile-bytestructures
                          (ssh -> guile-ssh) (tls -> gnutls)))))
 
 (define (old-style-guix? drv)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index e1073ea39b..bde937044a 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -622,7 +622,7 @@ that form."
      (display ")" port))))
 
 (define derivation->bytevector
-  (mlambda (drv)
+  (lambda (drv)
     "Return the external representation of DRV as a UTF-8-encoded string."
     (with-fluids ((%default-port-encoding "UTF-8"))
       (call-with-values open-bytevector-output-port
@@ -919,7 +919,6 @@ derivation.  It is kept as-is, uninterpreted, in the derivation."
 long-running processes that know what they're doing.  Use with care!"
   ;; Typically this is meant to be used by Cuirass and Hydra, which can clear
   ;; caches when they start evaluating packages for another architecture.
-  (invalidate-memoization! derivation->bytevector)
   (invalidate-memoization! derivation-base16-hash)
 
   ;; FIXME: Comment out to work around <https://bugs.gnu.org/36487>.
@@ -1207,6 +1206,26 @@ they can refer to each other."
                                   #:guile-for-build guile
                                   #:local-build? #t)))
 
+(define %module-cache
+  ;; Map a list of modules to its 'imported+compiled-modules' result.
+  (make-weak-value-hash-table))
+
+(define* (imported+compiled-modules store modules #:key
+                                    (system (%current-system))
+                                    (guile (%guile-for-build)))
+  "Return a pair containing the derivation to import MODULES and that where
+MODULES are compiled."
+  (define key
+    (list modules (derivation-file-name guile) system))
+
+  (or (hash-ref %module-cache key)
+      (let ((result (cons (%imported-modules store modules
+                                             #:system system #:guile guile)
+                          (%compiled-modules store modules
+                                             #:system system #:guile guile))))
+        (hash-set! %module-cache key result)
+        result)))
+
 (define* (build-expression->derivation store name exp ;deprecated
                                        #:key
                                        (system (%current-system))
@@ -1330,16 +1349,15 @@ and PROPERTIES."
                                       ;; fixed-output.
                                       (filter-map source-path inputs)))
 
-         (mod-drv  (and (pair? modules)
-                        (%imported-modules store modules
-                                           #:guile guile-drv
-                                           #:system system)))
+         (mod+go-drv  (if (pair? modules)
+                          (imported+compiled-modules store modules
+                                                     #:guile guile-drv
+                                                     #:system system)
+                          '(#f . #f)))
+         (mod-drv  (car mod+go-drv))
+         (go-drv   (cdr mod+go-drv))
          (mod-dir  (and mod-drv
                         (derivation->output-path mod-drv)))
-         (go-drv   (and (pair? modules)
-                        (%compiled-modules store modules
-                                           #:guile guile-drv
-                                           #:system system)))
          (go-dir   (and go-drv
                         (derivation->output-path go-drv))))
     (derivation store name guile
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 7323277511..b640c079e4 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -654,6 +654,31 @@ names and file names suitable for the #:allowed-references argument to
   (load-path           lowered-gexp-load-path)    ;list of store items
   (load-compiled-path  lowered-gexp-load-compiled-path)) ;list of store items
 
+(define* (imported+compiled-modules modules system
+                                    #:key (extensions '())
+                                    deprecation-warnings guile
+                                    (module-path %load-path))
+  "Return a pair where the first element is the imported MODULES and the
+second element is the derivation to compile them."
+  (mcached equal?
+           (mlet %store-monad ((modules  (if (pair? modules)
+                                             (imported-modules modules
+                                                               #:system system
+                                                               #:module-path module-path)
+                                             (return #f)))
+                               (compiled (if (pair? modules)
+                                             (compiled-modules modules
+                                                               #:system system
+                                                               #:module-path module-path
+                                                               #:extensions extensions
+                                                               #:guile guile
+                                                               #:deprecation-warnings
+                                                               deprecation-warnings)
+                                             (return #f))))
+             (return (cons modules compiled)))
+           modules
+           system extensions guile deprecation-warnings module-path))
+
 (define* (lower-gexp exp
                      #:key
                      (module-path %load-path)
@@ -719,20 +744,15 @@ derivations--e.g., code evaluated for its side effects."
                                        (lambda (obj)
                                          (lower-object obj system))
                                        extensions))
-                       (modules  (if (pair? %modules)
-                                     (imported-modules %modules
-                                                       #:system system
-                                                       #:module-path module-path)
-                                     (return #f)))
-                       (compiled (if (pair? %modules)
-                                     (compiled-modules %modules
-                                                       #:system system
-                                                       #:module-path module-path
-                                                       #:extensions extensions
-                                                       #:guile guile
-                                                       #:deprecation-warnings
-                                                       deprecation-warnings)
-                                     (return #f))))
+                       (modules+compiled (imported+compiled-modules
+                                          %modules system
+                                          #:extensions extensions
+                                          #:deprecation-warnings
+                                          deprecation-warnings
+                                          #:guile guile
+                                          #:module-path module-path))
+                       (modules ->  (car modules+compiled))
+                       (compiled -> (cdr modules+compiled)))
     (define load-path
       (search-path modules exts
                    (string-append "/share/guile/site/" effective-version)))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 7876019eac..80d070652b 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -714,6 +714,9 @@ transformations specified in OPTS (resulting from '--url', '--commit', or
   (define default-file
     (string-append (config-directory) "/channels.scm"))
 
+  (define global-file
+    (string-append %sysconfdir "/guix/channels.scm"))
+
   (define (load-channels file)
     (let ((result (load* file (make-user-module '((guix channels))))))
       (if (and (list? result) (every channel? result))
@@ -725,6 +728,8 @@ transformations specified in OPTS (resulting from '--url', '--commit', or
            (load-channels file))
           ((file-exists? default-file)
            (load-channels default-file))
+          ((file-exists? global-file)
+           (load-channels global-file))
           (else
            %default-channels)))
 
diff --git a/guix/store.scm b/guix/store.scm
index 382aad29d9..a276554a52 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1612,10 +1612,11 @@ This makes sense only when the daemon was started with '--cache-failures'."
 ;; from %STATE-MONAD.
 (template-directory instantiations %store-monad)
 
-(define* (cache-object-mapping object keys result)
+(define* (cache-object-mapping object keys result
+                               #:key (vhash-cons vhash-consq))
   "Augment the store's object cache with a mapping from OBJECT/KEYS to RESULT.
 KEYS is a list of additional keys to match against, for instance a (SYSTEM
-TARGET) tuple.
+TARGET) tuple.  Use VHASH-CONS to insert OBJECT into the cache.
 
 OBJECT is typically a high-level object such as a <package> or an <origin>,
 and RESULT is typically its derivation."
@@ -1623,8 +1624,8 @@ and RESULT is typically its derivation."
     (values result
             (store-connection
              (inherit store)
-             (object-cache (vhash-consq object (cons result keys)
-                                        (store-connection-object-cache store)))))))
+             (object-cache (vhash-cons object (cons result keys)
+                                       (store-connection-object-cache store)))))))
 
 (define record-cache-lookup!
   (if (profiled? "object-cache")
@@ -1653,11 +1654,12 @@ and RESULT is typically its derivation."
       (lambda (x y)
         #t)))
 
-(define* (lookup-cached-object object #:optional (keys '()))
+(define* (lookup-cached-object object #:optional (keys '())
+                               #:key (vhash-fold* vhash-foldq*))
   "Return the cached object in the store connection corresponding to OBJECT
-and KEYS.  KEYS is a list of additional keys to match against, and which are
-compared with 'equal?'.  Return #f on failure and the cached result
-otherwise."
+and KEYS; use VHASH-FOLD* to look for OBJECT in the cache.  KEYS is a list of
+additional keys to match against, and which are compared with 'equal?'.
+Return #f on failure and the cached result otherwise."
   (lambda (store)
     (let* ((cache (store-connection-object-cache store))
 
@@ -1665,33 +1667,50 @@ otherwise."
            ;; the whole vlist chain and significantly reduces the number of
            ;; 'hashq' calls.
            (value (let/ec return
-                    (vhash-foldq* (lambda (item result)
-                                    (match item
-                                      ((value . keys*)
-                                       (if (equal? keys keys*)
-                                           (return value)
-                                           result))))
-                                  #f object
-                                  cache))))
+                    (vhash-fold* (lambda (item result)
+                                   (match item
+                                     ((value . keys*)
+                                      (if (equal? keys keys*)
+                                          (return value)
+                                          result))))
+                                 #f object
+                                 cache))))
       (record-cache-lookup! value cache)
       (values value store))))
 
-(define* (%mcached mthunk object #:optional (keys '()))
+(define* (%mcached mthunk object #:optional (keys '())
+                   #:key
+                   (vhash-cons vhash-consq)
+                   (vhash-fold* vhash-foldq*))
   "Bind the monadic value returned by MTHUNK, which supposedly corresponds to
-OBJECT/KEYS, or return its cached value."
-  (mlet %store-monad ((cached (lookup-cached-object object keys)))
+OBJECT/KEYS, or return its cached value.  Use VHASH-CONS to insert OBJECT into
+the cache, and VHASH-FOLD* to look it up."
+  (mlet %store-monad ((cached (lookup-cached-object object keys
+                                                    #:vhash-fold* vhash-fold*)))
     (if cached
         (return cached)
         (>>= (mthunk)
              (lambda (result)
-               (cache-object-mapping object keys result))))))
+               (cache-object-mapping object keys result
+                                     #:vhash-cons vhash-cons))))))
 
-(define-syntax-rule (mcached mvalue object keys ...)
-  "Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the
+(define-syntax mcached
+  (syntax-rules (eq? equal?)
+    "Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the
 value associated with OBJECT/KEYS in the store's object cache if there is
 one."
-  (%mcached (lambda () mvalue)
-            object (list keys ...)))
+    ((_ eq? mvalue object keys ...)
+     (%mcached (lambda () mvalue)
+               object (list keys ...)
+               #:vhash-cons vhash-consq
+               #:vhash-fold* vhash-foldq*))
+    ((_ equal? mvalue object keys ...)
+     (%mcached (lambda () mvalue)
+               object (list keys ...)
+               #:vhash-cons vhash-cons
+               #:vhash-fold* vhash-fold*))
+    ((_ mvalue object keys ...)
+     (mcached eq? mvalue object keys ...))))
 
 (define (preserve-documentation original proc)
   "Return PROC with documentation taken from ORIGINAL."