diff options
author | Marius Bakke <mbakke@fastmail.com> | 2017-10-24 22:00:23 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2017-10-24 22:00:23 +0200 |
commit | ca4fd41de892c7055ce140863382c332441b15d3 (patch) | |
tree | 39872899c5bc649e11172dccb2f262a56f234661 /guix | |
parent | 7276eca4dcbe513922d5a778ee5fc8f2b2649642 (diff) | |
parent | 648c896ad3b198a1742c1ee8f66a1922aa98c1d8 (diff) | |
download | guix-patches-ca4fd41de892c7055ce140863382c332441b15d3.tar guix-patches-ca4fd41de892c7055ce140863382c332441b15d3.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/go.scm | 2 | ||||
-rw-r--r-- | guix/build/compile.scm | 165 | ||||
-rw-r--r-- | guix/build/go-build-system.scm | 10 | ||||
-rw-r--r-- | guix/build/pull.scm | 115 | ||||
-rw-r--r-- | guix/discovery.scm | 8 | ||||
-rw-r--r-- | guix/gexp.scm | 52 | ||||
-rw-r--r-- | guix/modules.scm | 10 |
7 files changed, 275 insertions, 87 deletions
diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 43599df6f4..ec447d2a28 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -78,6 +78,7 @@ %standard-phases)) (outputs '("out")) (search-paths '()) + (install-source? #t) (import-path "") (unpack-path "") (tests? #t) @@ -102,6 +103,7 @@ #:outputs %outputs #:search-paths ',(map search-path-specification->sexp search-paths) + #:install-source? ,install-source? #:import-path ,import-path #:unpack-path ,unpack-path #:tests? ,tests? diff --git a/guix/build/compile.scm b/guix/build/compile.scm new file mode 100644 index 0000000000..ea0c36fa33 --- /dev/null +++ b/guix/build/compile.scm @@ -0,0 +1,165 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build compile) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 threads) + #:use-module (system base target) + #:use-module (system base compile) + #:use-module (system base message) + #:use-module (guix modules) + #:use-module (guix build utils) + #:export (%default-optimizations + %lightweight-optimizations + compile-files)) + +;;; Commentary: +;;; +;;; Support code to compile Guile code as efficiently as possible (both with +;;; Guile 2.0 and 2.2). +;;; +;;; Code: + +(cond-expand + (guile-2.2 (use-modules (language tree-il optimize) + (language cps optimize))) + (else #f)) + +(define %default-optimizations + ;; Default optimization options (equivalent to -O2 on Guile 2.2). + (cond-expand + (guile-2.2 (append (tree-il-default-optimization-options) + (cps-default-optimization-options))) + (else '()))) + +(define %lightweight-optimizations + ;; Lightweight optimizations (like -O0, but with partial evaluation). + (let loop ((opts %default-optimizations) + (result '())) + (match opts + (() (reverse result)) + ((#:partial-eval? _ rest ...) + (loop rest `(#t #:partial-eval? ,@result))) + ((kw _ rest ...) + (loop rest `(#f ,kw ,@result)))))) + +(define %warnings + ;; FIXME: 'format' is missing because it reports "non-literal format + ;; strings" due to the fact that we use 'G_' instead of '_'. We'll need + ;; help from Guile to solve this. + '(unsupported-warning unbound-variable arity-mismatch + macro-use-before-definition)) ;new in 2.2 + +(define (optimization-options file) + "Return the default set of optimizations options for FILE." + (if (string-contains file "gnu/packages/") + %lightweight-optimizations ;build faster + '())) + +(define (scm->go file) + "Strip the \".scm\" suffix from FILE, and append \".go\"." + (string-append (string-drop-right file 4) ".go")) + +(define* (load-files directory files + #:key + (report-load (const #f)) + (debug-port (%make-void-port "w"))) + "Load FILES, a list of relative file names, from DIRECTORY." + (define total + (length files)) + + (let loop ((files files) + (completed 0)) + (match files + (() + (unless (zero? total) + (report-load #f total completed)) + *unspecified*) + ((file files ...) + (report-load file total completed) + (format debug-port "~%loading '~a'...~%" file) + + (parameterize ((current-warning-port debug-port)) + (resolve-interface (file-name->module-name file))) + + (loop files (+ 1 completed)))))) + +(define-syntax-rule (with-augmented-search-path path item body ...) + "Within the dynamic extent of BODY, augment PATH by adding ITEM to the +front." + (let ((initial-value path)) + (dynamic-wind + (lambda () + (set! path (cons item path))) + (lambda () + body ...) + (lambda () + (set! path initial-value))))) + +(define* (compile-files source-directory build-directory files + #:key + (host %host-type) + (workers (current-processor-count)) + (optimization-options optimization-options) + (warning-options `(#:warnings ,%warnings)) + (report-load (const #f)) + (report-compilation (const #f)) + (debug-port (%make-void-port "w"))) + "Compile FILES, a list of source files taken from SOURCE-DIRECTORY, to +BUILD-DIRECTORY, using up to WORKERS parallel workers. The resulting object +files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." + (define progress-lock (make-mutex)) + (define total (length files)) + (define completed 0) + + (define (build file) + (with-mutex progress-lock + (report-compilation file total completed)) + (with-fluids ((*current-warning-prefix* "")) + (with-target host + (lambda () + (compile-file file + #:output-file (string-append build-directory "/" + (scm->go file)) + #:opts (append warning-options + (optimization-options file)))))) + (with-mutex progress-lock + (set! completed (+ 1 completed)))) + + (with-augmented-search-path %load-path source-directory + (with-augmented-search-path %load-compiled-path build-directory + ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all + ;; of FILES. + (load-files source-directory files + #:report-load report-load + #:debug-port debug-port) + + ;; Make sure compilation related modules are loaded before starting to + ;; compile files in parallel. + (compile #f) + + (n-par-for-each workers build files) + (unless (zero? total) + (report-compilation #f total total))))) + +;;; Local Variables: +;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2) +;;; eval: (put 'with-target 'scheme-indent-function 1) +;;; End: diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 7f04e3db8c..72af6ce7b6 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -126,13 +126,14 @@ unset. When SOURCE is a directory, copy it instead of unpacking." (zero? (system* "unzip" "-d" dest source)) (zero? (system* "tar" "-C" dest "-xvf" source)))))) -(define* (install-source #:key outputs #:allow-other-keys) +(define* (install-source #:key install-source? outputs #:allow-other-keys) "Install the source code to the output directory." (let* ((out (assoc-ref outputs "out")) (source "src") (dest (string-append out "/" source))) - (copy-recursively source dest #:keep-mtime? #t) - #t)) + (if install-source? + (copy-recursively source dest #:keep-mtime? #t) + #t))) (define (go-package? name) (string-prefix? "go-" name)) @@ -179,6 +180,9 @@ respectively." (zero? (system* "go" "install" "-v" ; print the name of packages as they are compiled "-x" ; print each command as it is invoked + ;; Respectively, strip the symbol table and debug + ;; information, and the DWARF symbol table. + "-ldflags=-s -w" import-path)) (begin (display (string-append "Building '" import-path "' failed.\n" diff --git a/guix/build/pull.scm b/guix/build/pull.scm index 1ae35ab382..3573241a7e 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -20,11 +20,10 @@ (define-module (guix build pull) #:use-module (guix modules) #:use-module (guix build utils) - #:use-module (system base compile) + #:use-module (guix build compile) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:use-module (ice-9 threads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -63,34 +62,6 @@ available, false otherwise." (string-prefix? gnu b)) (string<? a b)))))) -(cond-expand - (guile-2.2 (use-modules (language tree-il optimize) - (language cps optimize))) - (else #f)) - -(define %default-optimizations - ;; Default optimization options (equivalent to -O2 on Guile 2.2). - (cond-expand - (guile-2.2 (append (tree-il-default-optimization-options) - (cps-default-optimization-options))) - (else '()))) - -(define %lightweight-optimizations - ;; Lightweight optimizations (like -O0, but with partial evaluation). - (let loop ((opts %default-optimizations) - (result '())) - (match opts - (() (reverse result)) - ((#:partial-eval? _ rest ...) - (loop rest `(#t #:partial-eval? ,@result))) - ((kw _ rest ...) - (loop rest `(#f ,kw ,@result)))))) - -(define (optimization-options file) - (if (string-contains file "gnu/packages/") - %lightweight-optimizations ;build faster - '())) - (define* (build-guix out source #:key @@ -148,53 +119,43 @@ containing the source code. Write any debugging output to DEBUG-PORT." (set! %load-path (cons out %load-path)) (set! %load-compiled-path (cons out %load-compiled-path)) - ;; Compile the .scm files. Load all the files before compiling them to - ;; work around <http://bugs.gnu.org/15602> (FIXME). - ;; Filter out files depending on Guile-SSH when Guile-SSH is missing. - (let* ((files (filter has-all-its-dependencies? - (all-scheme-files out))) - (total (length files))) - (let loop ((files files) - (completed 0)) - (match files - (() *unspecified*) - ((file . files) - (display #\cr log-port) - (format log-port "loading...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output log-port) - (format debug-port "~%loading '~a'...~%" file) - ;; Turn "<out>/foo/bar.scm" into (foo bar). - (let* ((relative-file (string-drop file (+ (string-length out) 1))) - (module-path (string-drop-right relative-file 4)) - (module-name (map string->symbol - (string-split module-path #\/)))) - (parameterize ((current-warning-port debug-port)) - (resolve-interface module-name))) - (loop files (+ 1 completed))))) - (newline) - (let ((mutex (make-mutex)) - (completed 0)) - ;; Make sure compilation related modules are loaded before starting to - ;; compile files in parallel. - (compile #f) - (n-par-for-each - (parallel-job-count) - (lambda (file) - (with-mutex mutex - (display #\cr log-port) - (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output log-port) - (format debug-port "~%compiling '~a'...~%" file)) - (let ((go (string-append (string-drop-right file 4) ".go"))) - (parameterize ((current-warning-port (%make-void-port "w"))) - (compile-file file - #:output-file go - #:opts (optimization-options file)))) - (with-mutex mutex - (set! completed (+ 1 completed)))) - files)))) + ;; Compile the .scm files. Hide warnings. + (parameterize ((current-warning-port (%make-void-port "w"))) + (with-directory-excursion out + ;; Filter out files depending on Guile-SSH when Guile-SSH is missing. + (let ((files (filter has-all-its-dependencies? + (all-scheme-files ".")))) + (compile-files out out + + ;; XXX: 'compile-files' except ready-to-use relative + ;; file names. + (map (lambda (file) + (if (string-prefix? "./" file) + (string-drop file 2) + file)) + files) + + #:workers (parallel-job-count) + + ;; Disable warnings. + #:warning-options '() + + #:report-load + (lambda (file total completed) + (display #\cr log-port) + (format log-port + "loading...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port) + (format debug-port "~%loading '~a'...~%" file)) + + #:report-compilation + (lambda (file total completed) + (display #\cr log-port) + (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port) + (format debug-port "~%compiling '~a'...~%" file))))))) (newline) #t) diff --git a/guix/discovery.scm b/guix/discovery.scm index 2741725b9d..7b57579023 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -18,6 +18,7 @@ (define-module (guix discovery) #:use-module (guix ui) + #:use-module (guix modules) #:use-module (guix combinators) #:use-module (guix build syscalls) #:use-module (srfi srfi-1) @@ -88,13 +89,6 @@ DIRECTORY is not accessible." directory (strerror errno))) '()))))) -(define file-name->module-name - (let ((not-slash (char-set-complement (char-set #\/)))) - (lambda (file) - "Return the module name (a list of symbols) corresponding to FILE." - (map string->symbol - (string-tokenize (string-drop-right file 4) not-slash))))) - (define* (scheme-modules directory #:optional sub-directory) "Return the list of Scheme modules available under DIRECTORY. Optionally, narrow the search to SUB-DIRECTORY." diff --git a/guix/gexp.scm b/guix/gexp.scm index 2622c5cb62..b9525603ee 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -78,6 +78,8 @@ gexp->script text-file* mixed-text-file + file-union + directory-union imported-files imported-modules compiled-modules @@ -1171,6 +1173,56 @@ This is the declarative counterpart of 'text-file*'." (computed-file name build)) +(define (file-union name files) + "Return a <computed-file> that builds a directory containing all of FILES. +Each item in FILES must be a two-element list where the first element is the +file name to use in the new directory, and the second element is a gexp +denoting the target file. Here's an example: + + (file-union \"etc\" + `((\"hosts\" ,(plain-file \"hosts\" + \"127.0.0.1 localhost\")) + (\"bashrc\" ,(plain-file \"bashrc\" + \"alias ls='ls --color'\")))) + +This yields an 'etc' directory containing these two files." + (computed-file name + (gexp + (begin + (mkdir (ungexp output)) + (chdir (ungexp output)) + (ungexp-splicing + (map (match-lambda + ((target source) + (gexp + (begin + ;; Stat the source to abort early if it does + ;; not exist. + (stat (ungexp source)) + + (symlink (ungexp source) + (ungexp target)))))) + files)))))) + +(define (directory-union name things) + "Return a directory that is the union of THINGS, where THINGS is a list of +file-like objects denoting directories. For example: + + (directory-union \"guile+emacs\" (list guile emacs)) + +yields a directory that is the union of the 'guile' and 'emacs' packages." + (match things + ((one) + ;; Only one thing; return it. + one) + (_ + (computed-file name + (with-imported-modules '((guix build union)) + (gexp (begin + (use-modules (guix build union)) + (union-build (ungexp output) + '(ungexp things))))))))) + ;;; ;;; Syntactic sugar. diff --git a/guix/modules.scm b/guix/modules.scm index 19a4acd76c..6c602eda48 100644 --- a/guix/modules.scm +++ b/guix/modules.scm @@ -26,6 +26,9 @@ #:export (missing-dependency-error? missing-dependency-module + file-name->module-name + module-name->file-name + source-module-closure live-module-closure guix-module-name?)) @@ -93,6 +96,13 @@ depends on." (_ '())))))) +(define file-name->module-name + (let ((not-slash (char-set-complement (char-set #\/)))) + (lambda (file) + "Return the module name (a list of symbols) corresponding to FILE." + (map string->symbol + (string-tokenize (string-drop-right file 4) not-slash))))) + (define (module-name->file-name module) "Return the file name for MODULE." (string-append (string-join (map symbol->string module) "/") |