From 2eafeb2f3d661061bc412c3f27c90202e4532532 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 26 Mar 2021 10:52:24 +0100 Subject: [PATCH] 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. --- guix/gexp.scm | 262 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 160 insertions(+), 102 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! write-gexp) +(define (gexp-with-hidden-inputs gexp inputs) + "Add INPUTS, a list of , 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)) + (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 modules + (getenv "modules")) - (define (regular? file) - (not (member file '("." "..")))) + (define total + (string->number (getenv "module count"))) - (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) + (define extensions + (string-split (getenv "extensions") #\space)) - (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)))))) + (define target + (getenv "target")) - (+ 1 processed)))) + (define optimization-level + (string->number (getenv "optimization level"))) - (define (process-directory directory output processed) - (let ((entries (map (cut string-append directory "/" <>) - (scandir directory regular?)))) - (fold (cut process-entry <> output <>) - processed - entries))) + (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* (load-from-directory directory - #:optional (loaded 0)) - "Load all the source files found in DIRECTORY." - ;; XXX: This works around . - (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))) + (define (regular? file) + (not (member file '("." "..")))) - (setvbuf (current-output-port) - (cond-expand (guile-2.2 'line) (else _IOLBF))) + (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) - (define mkdir-p - ;; Capture 'mkdir-p'. - (@ (guix build utils) mkdir-p)) + (with-target (or target %host-type) + (lambda () + (compile-file entry + #:output-file output + #:opts + `(,@%auto-compilation-options + ,@(optimizations-for-level + optimization-level))))) - ;; 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)) + (+ 1 processed)))) - (set! %load-path (cons (ungexp modules) %load-path)) + (define (process-directory directory output processed) + (let ((entries (map (cut string-append directory "/" <>) + (scandir directory regular?)))) + (fold (cut process-entry <> output <>) + processed + entries))) - ;; 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))) + (define* (load-from-directory directory + #:optional (loaded 0)) + "Load all the source files found in DIRECTORY." + ;; XXX: This works around . + (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))) - (mkdir (ungexp output)) - (chdir (ungexp modules)) + (setvbuf (current-output-port) + (cond-expand (guile-2.2 'line) (else _IOLBF))) - (load-from-directory ".") - (process-directory "." (ungexp output) 0)))) + (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)))) - ;; 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 + '())))))) ;;;