me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2021-03-26 10:52:24 +01:00
parent f27a7c18b6
commit 2eafeb2f3d
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 160 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

262
guix/gexp.scm
View File

@ -184,6 +184,18 @@
(set-record-type-printer! <gexp> write-gexp) (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. ;;; Methods.
@ -1614,131 +1626,177 @@ TARGET, a GNU triplet."
#:system system #:system system
#:guile guile #:guile guile
#:module-path #:module-path
module-path))) module-path))
(extensions (mapm %store-monad
(lambda (extension)
(lower-object extension system
#:target #f))
extensions)))
(define build (define build
(gexp (gexp-with-hidden-inputs
(begin (gexp
(primitive-load (ungexp %utils-module)) ;for 'mkdir-p' (begin
(primitive-load (ungexp %utils-module)) ;for 'mkdir-p'
(use-modules (ice-9 ftw) (use-modules (ice-9 ftw)
(ice-9 format) (ice-9 format)
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-26) (srfi srfi-26)
(system base target) (system base target)
(system base compile)) (system base compile))
(define optimizations-for-level (define modules
(or (and=> (false-if-exception (getenv "modules"))
(resolve-interface '(system base optimize)))
(lambda (iface)
(module-ref iface 'optimizations-for-level))) ;Guile 3.0
(const '())))
(define (regular? file) (define total
(not (member file '("." "..")))) (string->number (getenv "module count")))
(define (process-entry entry output processed) (define extensions
(if (file-is-directory? entry) (string-split (getenv "extensions") #\space))
(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))) (define target
(lambda () (getenv "target"))
(compile-file entry
#:output-file output
#:opts
`(,@%auto-compilation-options
,@(optimizations-for-level
(ungexp optimization-level))))))
(+ 1 processed)))) (define optimization-level
(string->number (getenv "optimization level")))
(define (process-directory directory output processed) (define optimizations-for-level
(let ((entries (map (cut string-append directory "/" <>) (or (and=> (false-if-exception
(scandir directory regular?)))) (resolve-interface '(system base optimize)))
(fold (cut process-entry <> output <>) (lambda (iface)
processed (module-ref iface 'optimizations-for-level))) ;Guile 3.0
entries))) (const '())))
(define* (load-from-directory directory (define (regular? file)
#:optional (loaded 0)) (not (member file '("." ".."))))
"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) (define (process-entry entry output processed)
(cond-expand (guile-2.2 'line) (else _IOLBF))) (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 (with-target (or target %host-type)
;; Capture 'mkdir-p'. (lambda ()
(@ (guix build utils) mkdir-p)) (compile-file entry
#:output-file output
#:opts
`(,@%auto-compilation-options
,@(optimizations-for-level
optimization-level)))))
;; Add EXTENSIONS to the search path. (+ 1 processed))))
(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)) (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 (define* (load-from-directory directory
;; load a compile a different one. Thus, force a reload. #:optional (loaded 0))
(let ((utils (string-append (ungexp modules) "Load all the source files found in DIRECTORY."
"/guix/build/utils.scm"))) ;; XXX: This works around <https://bugs.gnu.org/15602>.
(when (file-exists? utils) (let ((entries (map (cut string-append directory "/" <>)
(load utils))) (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)) (setvbuf (current-output-port)
(chdir (ungexp modules)) (cond-expand (guile-2.2 'line) (else _IOLBF)))
(load-from-directory ".") (define mkdir-p
(process-directory "." (ungexp output) 0)))) ;; 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 (gexp->derivation name build
#:script-name "compile-modules"
#:system system #:system system
#:target target #:target target
#:guile-for-build guile #:guile-for-build guile
#:local-build? #t #:local-build? #t
#:env-vars #:env-vars
(case deprecation-warnings `(("modules"
((#f) . ,(if (derivation? modules)
'(("GUILE_WARN_DEPRECATED" . "no"))) (derivation->output-path modules)
((detailed) modules))
'(("GUILE_WARN_DEPRECATED" . "detailed"))) ("module count" . ,(number->string total))
(else ("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
'()))))))
;;; ;;;