diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-10-30 14:32:53 +0100 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-10-30 14:32:53 +0100 |
commit | 998e6cdcd2a9fcce18b46676ce47990867227945 (patch) | |
tree | 5b6b08860183d164108257a3715e0c5673063f5a /guix | |
parent | a557810ac72effd6841b76772195b10c03dee345 (diff) | |
parent | d8bb1097d764949e80f9e41d26b3b194163dd716 (diff) | |
download | patches-998e6cdcd2a9fcce18b46676ce47990867227945.tar patches-998e6cdcd2a9fcce18b46676ce47990867227945.tar.gz |
Merge branch 'master' into staging
Diffstat (limited to 'guix')
-rw-r--r-- | guix/channels.scm | 2 | ||||
-rw-r--r-- | guix/derivations.scm | 38 | ||||
-rw-r--r-- | guix/gexp.scm | 48 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 5 | ||||
-rw-r--r-- | guix/store.scm | 67 |
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." |