summaryrefslogtreecommitdiff
path: root/guix/gexp.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-03-26 10:52:24 +0100
committerLudovic Courtès <ludo@gnu.org>2021-03-30 22:48:46 +0200
commit2eafeb2f3d661061bc412c3f27c90202e4532532 (patch)
tree91610eb5b6a673dd283487b9d46a5d86e174dd35 /guix/gexp.scm
parentf27a7c18b6eea7e476cf76c701db1f0cd2fd50c8 (diff)
gexp: 'compiled-modules' gets source and parameters an environment variables.
This reduces the number of 'add-text-to-store' RPCs by 15 (out of 3336) oin "guix build -d --no-grafts libreoffice". * guix/gexp.scm (gexp-with-hidden-inputs): New procedure. (compiled-modules): Use it. Pass #:script-name. Augment #:env-vars.
Diffstat (limited to 'guix/gexp.scm')
-rw-r--r--guix/gexp.scm292
1 files changed, 175 insertions, 117 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 840af8f0f1..77ef2a4fb8 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -184,6 +184,18 @@
(set-record-type-printer! <gexp> write-gexp)
+(define (gexp-with-hidden-inputs gexp inputs)
+ "Add INPUTS, a list of <gexp-input>, to the references of GEXP. These are
+\"hidden inputs\" because they do not actually appear in the expansion of GEXP
+returned by 'gexp->sexp'."
+ (make-gexp (append inputs (gexp-references gexp))
+ (gexp-self-modules gexp)
+ (gexp-self-extensions gexp)
+ (let ((extra (length inputs)))
+ (lambda args
+ (apply (gexp-proc gexp) (drop args extra))))
+ (gexp-location gexp)))
+
;;;
;;; Methods.
@@ -1614,131 +1626,177 @@ TARGET, a GNU triplet."
#:system system
#:guile guile
#:module-path
- module-path)))
+ module-path))
+ (extensions (mapm %store-monad
+ (lambda (extension)
+ (lower-object extension system
+ #:target #f))
+ extensions)))
(define build
- (gexp
- (begin
- (primitive-load (ungexp %utils-module)) ;for 'mkdir-p'
+ (gexp-with-hidden-inputs
+ (gexp
+ (begin
+ (primitive-load (ungexp %utils-module)) ;for 'mkdir-p'
+
+ (use-modules (ice-9 ftw)
+ (ice-9 format)
+ (srfi srfi-1)
+ (srfi srfi-26)
+ (system base target)
+ (system base compile))
+
+ (define modules
+ (getenv "modules"))
+
+ (define total
+ (string->number (getenv "module count")))
+
+ (define extensions
+ (string-split (getenv "extensions") #\space))
+
+ (define target
+ (getenv "target"))
+
+ (define optimization-level
+ (string->number (getenv "optimization level")))
+
+ (define optimizations-for-level
+ (or (and=> (false-if-exception
+ (resolve-interface '(system base optimize)))
+ (lambda (iface)
+ (module-ref iface 'optimizations-for-level))) ;Guile 3.0
+ (const '())))
+
+ (define (regular? file)
+ (not (member file '("." ".."))))
+
+ (define (process-entry entry output processed)
+ (if (file-is-directory? entry)
+ (let ((output (string-append output "/" (basename entry))))
+ (mkdir-p output)
+ (process-directory entry output processed))
+ (let* ((base (basename entry ".scm"))
+ (output (string-append output "/" base ".go")))
+ (format #t "[~2@a/~2@a] Compiling '~a'...~%"
+ (+ 1 processed total)
+ (* total 2)
+ entry)
+
+ (with-target (or target %host-type)
+ (lambda ()
+ (compile-file entry
+ #:output-file output
+ #:opts
+ `(,@%auto-compilation-options
+ ,@(optimizations-for-level
+ optimization-level)))))
+
+ (+ 1 processed))))
+
+ (define (process-directory directory output processed)
+ (let ((entries (map (cut string-append directory "/" <>)
+ (scandir directory regular?))))
+ (fold (cut process-entry <> output <>)
+ processed
+ entries)))
+
+ (define* (load-from-directory directory
+ #:optional (loaded 0))
+ "Load all the source files found in DIRECTORY."
+ ;; XXX: This works around <https://bugs.gnu.org/15602>.
+ (let ((entries (map (cut string-append directory "/" <>)
+ (scandir directory regular?))))
+ (fold (lambda (file loaded)
+ (if (file-is-directory? file)
+ (load-from-directory file loaded)
+ (begin
+ (format #t "[~2@a/~2@a] Loading '~a'...~%"
+ (+ 1 loaded) (* 2 total)
+ file)
+ (save-module-excursion
+ (lambda ()
+ (primitive-load file)))
+ (+ 1 loaded))))
+ loaded
+ entries)))
+
+ (setvbuf (current-output-port)
+ (cond-expand (guile-2.2 'line) (else _IOLBF)))
+
+ (define mkdir-p
+ ;; Capture 'mkdir-p'.
+ (@ (guix build utils) mkdir-p))
+
+ ;; Remove environment variables for internal consumption.
+ (unsetenv "modules")
+ (unsetenv "module count")
+ (unsetenv "extensions")
+ (unsetenv "target")
+ (unsetenv "optimization level")
+
+ ;; Add EXTENSIONS to the search path.
+ (set! %load-path
+ (append (map (lambda (extension)
+ (string-append extension
+ "/share/guile/site/"
+ (effective-version)))
+ extensions)
+ %load-path))
+ (set! %load-compiled-path
+ (append (map (lambda (extension)
+ (string-append extension "/lib/guile/"
+ (effective-version)
+ "/site-ccache"))
+ extensions)
+ %load-compiled-path))
+
+ (set! %load-path (cons modules %load-path))
+
+ ;; Above we loaded our own (guix build utils) but now we may need to
+ ;; load a compile a different one. Thus, force a reload.
+ (let ((utils (string-append modules
+ "/guix/build/utils.scm")))
+ (when (file-exists? utils)
+ (load utils)))
+
+ (mkdir (ungexp output))
+ (chdir modules)
+
+ (load-from-directory ".")
+ (process-directory "." (ungexp output) 0)))
+ (list (gexp-input modules))))
- (use-modules (ice-9 ftw)
- (ice-9 format)
- (srfi srfi-1)
- (srfi srfi-26)
- (system base target)
- (system base compile))
-
- (define optimizations-for-level
- (or (and=> (false-if-exception
- (resolve-interface '(system base optimize)))
- (lambda (iface)
- (module-ref iface 'optimizations-for-level))) ;Guile 3.0
- (const '())))
-
- (define (regular? file)
- (not (member file '("." ".."))))
-
- (define (process-entry entry output processed)
- (if (file-is-directory? entry)
- (let ((output (string-append output "/" (basename entry))))
- (mkdir-p output)
- (process-directory entry output processed))
- (let* ((base (basename entry ".scm"))
- (output (string-append output "/" base ".go")))
- (format #t "[~2@a/~2@a] Compiling '~a'...~%"
- (+ 1 processed (ungexp total))
- (ungexp (* total 2))
- entry)
-
- (with-target (ungexp (or target (gexp %host-type)))
- (lambda ()
- (compile-file entry
- #:output-file output
- #:opts
- `(,@%auto-compilation-options
- ,@(optimizations-for-level
- (ungexp optimization-level))))))
-
- (+ 1 processed))))
-
- (define (process-directory directory output processed)
- (let ((entries (map (cut string-append directory "/" <>)
- (scandir directory regular?))))
- (fold (cut process-entry <> output <>)
- processed
- entries)))
-
- (define* (load-from-directory directory
- #:optional (loaded 0))
- "Load all the source files found in DIRECTORY."
- ;; XXX: This works around <https://bugs.gnu.org/15602>.
- (let ((entries (map (cut string-append directory "/" <>)
- (scandir directory regular?))))
- (fold (lambda (file loaded)
- (if (file-is-directory? file)
- (load-from-directory file loaded)
- (begin
- (format #t "[~2@a/~2@a] Loading '~a'...~%"
- (+ 1 loaded) (ungexp (* 2 total))
- file)
- (save-module-excursion
- (lambda ()
- (primitive-load file)))
- (+ 1 loaded))))
- loaded
- entries)))
-
- (setvbuf (current-output-port)
- (cond-expand (guile-2.2 'line) (else _IOLBF)))
-
- (define mkdir-p
- ;; Capture 'mkdir-p'.
- (@ (guix build utils) mkdir-p))
-
- ;; Add EXTENSIONS to the search path.
- (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))
-
- ;; Above we loaded our own (guix build utils) but now we may need to
- ;; load a compile a different one. Thus, force a reload.
- (let ((utils (string-append (ungexp modules)
- "/guix/build/utils.scm")))
- (when (file-exists? utils)
- (load utils)))
-
- (mkdir (ungexp output))
- (chdir (ungexp modules))
-
- (load-from-directory ".")
- (process-directory "." (ungexp output) 0))))
-
- ;; TODO: Pass MODULES as an environment variable.
(gexp->derivation name build
+ #:script-name "compile-modules"
#:system system
#:target target
#:guile-for-build guile
#:local-build? #t
#:env-vars
- (case deprecation-warnings
- ((#f)
- '(("GUILE_WARN_DEPRECATED" . "no")))
- ((detailed)
- '(("GUILE_WARN_DEPRECATED" . "detailed")))
- (else
- '())))))
+ `(("modules"
+ . ,(if (derivation? modules)
+ (derivation->output-path modules)
+ modules))
+ ("module count" . ,(number->string total))
+ ("extensions"
+ . ,(string-join
+ (map (match-lambda
+ ((? derivation? drv)
+ (derivation->output-path drv))
+ ((? string? str) str))
+ extensions)))
+ ("optimization level"
+ . ,(number->string optimization-level))
+ ,@(if target
+ `(("target" . ,target))
+ '())
+ ,@(case deprecation-warnings
+ ((#f)
+ '(("GUILE_WARN_DEPRECATED" . "no")))
+ ((detailed)
+ '(("GUILE_WARN_DEPRECATED" . "detailed")))
+ (else
+ '()))))))
;;;