e006f7493f
* guix/build/guile-build-system.scm (report-build-progress): Use a format string suitable for (guix status).
234 lines
8.6 KiB
Scheme
234 lines
8.6 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
|
;;;
|
|
;;; 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 guile-build-system)
|
|
#:use-module ((guix build gnu-build-system) #:prefix gnu:)
|
|
#:use-module (guix build utils)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 popen)
|
|
#:use-module (ice-9 rdelim)
|
|
#:use-module (ice-9 regex)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (guix build utils)
|
|
#:export (target-guile-effective-version
|
|
%standard-phases
|
|
guile-build))
|
|
|
|
(define* (target-guile-effective-version #:optional guile)
|
|
"Return the effective version of GUILE or whichever 'guile' is in $PATH.
|
|
Return #false if it cannot be determined."
|
|
(let* ((pipe (open-pipe* OPEN_READ
|
|
(if guile
|
|
(string-append guile "/bin/guile")
|
|
"guile")
|
|
"-c" "(display (effective-version))"))
|
|
(line (read-line pipe)))
|
|
(and (zero? (close-pipe pipe))
|
|
(string? line)
|
|
line)))
|
|
|
|
(define (file-sans-extension file) ;TODO: factorize
|
|
"Return the substring of FILE without its extension, if any."
|
|
(let ((dot (string-rindex file #\.)))
|
|
(if dot
|
|
(substring file 0 dot)
|
|
file)))
|
|
|
|
(define %scheme-file-regexp
|
|
;; Regexp to match Scheme files.
|
|
"\\.(scm|sls)$")
|
|
|
|
(define %documentation-file-regexp
|
|
;; Regexp to match README files and the likes.
|
|
"^(README.*|.*\\.html|.*\\.org|.*\\.md)$")
|
|
|
|
(define* (set-locale-path #:key inputs native-inputs
|
|
#:allow-other-keys)
|
|
"Set 'GUIX_LOCPATH'."
|
|
(match (assoc-ref (or native-inputs inputs) "locales")
|
|
(#f #t)
|
|
(locales
|
|
(setenv "GUIX_LOCPATH" (string-append locales "/lib/locale"))
|
|
#t)))
|
|
|
|
(define* (invoke-each commands
|
|
#:key (max-processes (current-processor-count))
|
|
report-progress)
|
|
"Run each command in COMMANDS in a separate process, using up to
|
|
MAX-PROCESSES processes in parallel. Call REPORT-PROGRESS at each step.
|
|
Raise an error if one of the processes exit with non-zero."
|
|
(define total
|
|
(length commands))
|
|
|
|
(define processes
|
|
(make-hash-table))
|
|
|
|
(define (wait-for-one-process)
|
|
(match (waitpid WAIT_ANY)
|
|
((pid . status)
|
|
(let ((command (hashv-ref processes pid)))
|
|
(hashv-remove! processes command)
|
|
(unless (zero? (status:exit-val status))
|
|
(format (current-error-port)
|
|
"process '~{~a ~}' failed with status ~a~%"
|
|
command status)
|
|
(exit 1))))))
|
|
|
|
(define (fork-and-run-command command)
|
|
(match (primitive-fork)
|
|
(0
|
|
(dynamic-wind
|
|
(const #t)
|
|
(lambda ()
|
|
(apply execlp command))
|
|
(lambda ()
|
|
(primitive-exit 127))))
|
|
(pid
|
|
(hashv-set! processes pid command)
|
|
#t)))
|
|
|
|
(let loop ((commands commands)
|
|
(running 0)
|
|
(completed 0))
|
|
(match commands
|
|
(()
|
|
(or (zero? running)
|
|
(let ((running (- running 1))
|
|
(completed (+ completed 1)))
|
|
(wait-for-one-process)
|
|
(report-progress total completed)
|
|
(loop commands running completed))))
|
|
((command . rest)
|
|
(if (< running max-processes)
|
|
(let ((running (+ 1 running)))
|
|
(fork-and-run-command command)
|
|
(loop rest running completed))
|
|
(let ((running (- running 1))
|
|
(completed (+ completed 1)))
|
|
(wait-for-one-process)
|
|
(report-progress total completed)
|
|
(loop commands running completed)))))))
|
|
|
|
(define* (report-build-progress total completed
|
|
#:optional (log-port (current-error-port)))
|
|
"Report that COMPLETED out of TOTAL files have been completed."
|
|
(format log-port "[~2d/~2d] Compiling...~%"
|
|
completed total)
|
|
(force-output log-port))
|
|
|
|
(define* (build #:key outputs inputs native-inputs
|
|
(source-directory ".")
|
|
(compile-flags '())
|
|
(scheme-file-regexp %scheme-file-regexp)
|
|
(not-compiled-file-regexp #f)
|
|
target
|
|
#:allow-other-keys)
|
|
"Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP. Files
|
|
matching NOT-COMPILED-FILE-REGEXP, if true, are not compiled but are
|
|
installed; this is useful for files that are meant to be included."
|
|
(let* ((out (assoc-ref outputs "out"))
|
|
(guile (assoc-ref (or native-inputs inputs) "guile"))
|
|
(effective (target-guile-effective-version guile))
|
|
(module-dir (string-append out "/share/guile/site/"
|
|
effective))
|
|
(go-dir (string-append out "/lib/guile/"
|
|
effective "/site-ccache/"))
|
|
(guild (string-append guile "/bin/guild"))
|
|
(flags (if target
|
|
(cons (string-append "--target=" target)
|
|
compile-flags)
|
|
compile-flags)))
|
|
(if target
|
|
(format #t "Cross-compiling for '~a' with Guile ~a...~%"
|
|
target effective)
|
|
(format #t "Compiling with Guile ~a...~%" effective))
|
|
(format #t "compile flags: ~s~%" flags)
|
|
|
|
;; Make installation directories.
|
|
(mkdir-p module-dir)
|
|
(mkdir-p go-dir)
|
|
|
|
;; Compile .scm files and install.
|
|
(setenv "GUILE_AUTO_COMPILE" "0")
|
|
(setenv "GUILE_LOAD_COMPILED_PATH"
|
|
(string-append go-dir
|
|
(match (getenv "GUILE_LOAD_COMPILED_PATH")
|
|
(#f "")
|
|
(path (string-append ":" path)))))
|
|
|
|
(let ((source-files
|
|
(with-directory-excursion source-directory
|
|
(find-files "." scheme-file-regexp))))
|
|
(invoke-each
|
|
(filter-map (lambda (file)
|
|
(and (or (not not-compiled-file-regexp)
|
|
(not (string-match not-compiled-file-regexp
|
|
file)))
|
|
(cons* guild
|
|
"guild" "compile"
|
|
"-L" source-directory
|
|
"-o" (string-append go-dir
|
|
(file-sans-extension file)
|
|
".go")
|
|
(string-append source-directory "/" file)
|
|
flags)))
|
|
source-files)
|
|
#:max-processes (parallel-job-count)
|
|
#:report-progress report-build-progress)
|
|
|
|
(for-each
|
|
(lambda (file)
|
|
(install-file (string-append source-directory "/" file)
|
|
(string-append module-dir
|
|
"/" (dirname file))))
|
|
source-files))
|
|
#t))
|
|
|
|
(define* (install-documentation #:key outputs
|
|
(documentation-file-regexp
|
|
%documentation-file-regexp)
|
|
#:allow-other-keys)
|
|
"Install files that mactch DOCUMENTATION-FILE-REGEXP."
|
|
(let* ((out (assoc-ref outputs "out"))
|
|
(doc (string-append out "/share/doc/"
|
|
(strip-store-file-name out))))
|
|
(for-each (cut install-file <> doc)
|
|
(find-files "." documentation-file-regexp))
|
|
#t))
|
|
|
|
(define %standard-phases
|
|
(modify-phases gnu:%standard-phases
|
|
(delete 'bootstrap)
|
|
(delete 'configure)
|
|
(add-before 'install-locale 'set-locale-path
|
|
set-locale-path)
|
|
(replace 'build build)
|
|
(add-after 'build 'install-documentation
|
|
install-documentation)
|
|
(delete 'check)
|
|
(delete 'strip)
|
|
(delete 'validate-runpath)
|
|
(delete 'install)))
|
|
|
|
(define* (guile-build #:key (phases %standard-phases)
|
|
#:allow-other-keys #:rest args)
|
|
"Build the given Guile package, applying all of PHASES in order."
|
|
(apply gnu:gnu-build #:phases phases args))
|