guix/build/gnu-build-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix build gnu-build-system)
  20   #:use-module (guix build utils)
  21   #:use-module (guix build gremlin)
  22   #:use-module (guix elf)
  23   #:use-module (ice-9 ftw)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 regex)
  26   #:use-module (ice-9 format)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-19)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (rnrs io ports)
  31   #:export (%standard-phases
  32             gnu-build))
  33
  34 ;; Commentary:
  35 ;;
  36 ;; Standard build procedure for packages using the GNU Build System or
  37 ;; something compatible ("./configure && make && make install").  This is the
  38 ;; builder-side code.
  39 ;;
  40 ;; Code:
  41
  42 (define* (set-SOURCE-DATE-EPOCH #:rest _)
  43   "Set the 'SOURCE_DATE_EPOCH' environment variable.  This is used by tools
  44 that incorporate timestamps as a way to tell them to use a fixed timestamp.
  45 See https://reproducible-builds.org/specs/source-date-epoch/."
  46   (setenv "SOURCE_DATE_EPOCH" "1")
  47   #t)
  48
  49 (define (first-subdirectory dir)
  50   "Return the path of the first sub-directory of DIR."
  51   (file-system-fold (lambda (path stat result)
  52                       (string=? path dir))
  53                     (lambda (path stat result) result) ; leaf
  54                     (lambda (path stat result) result) ; down
  55                     (lambda (path stat result) result) ; up
  56                     (lambda (path stat result)         ; skip
  57                       (or result path))
  58                     (lambda (path stat errno result)   ; error
  59                       (error "first-subdirectory" (strerror errno)))
  60                     #f
  61                     dir))
  62
  63 (define* (set-paths #:key target inputs native-inputs
  64                     (search-paths '()) (native-search-paths '())
  65                     #:allow-other-keys)
  66   (define input-directories
  67     (match inputs
  68       (((_ . dir) ...)
  69        dir)))
  70
  71   (define native-input-directories
  72     (match native-inputs
  73       (((_ . dir) ...)
  74        dir)
  75       (#f                                         ; not cross compiling
  76        '())))
  77
  78   ;; When cross building, $PATH must refer only to native (host) inputs since
  79   ;; target inputs are not executable.
  80   (set-path-environment-variable "PATH" '("bin" "sbin")
  81                                  (append native-input-directories
  82                                          (if target
  83                                              '()
  84                                              input-directories)))
  85
  86   (for-each (match-lambda
  87              ((env-var (files ...) separator type pattern)
  88               (set-path-environment-variable env-var files
  89                                              input-directories
  90                                              #:separator separator
  91                                              #:type type
  92                                              #:pattern pattern)))
  93             search-paths)
  94
  95   (when native-search-paths
  96     ;; Search paths for native inputs, when cross building.
  97     (for-each (match-lambda
  98                ((env-var (files ...) separator type pattern)
  99                 (set-path-environment-variable env-var files
 100                                                native-input-directories
 101                                                #:separator separator
 102                                                #:type type
 103                                                #:pattern pattern)))
 104               native-search-paths))
 105
 106   #t)
 107
 108 (define* (install-locale #:key
 109                          (locale "en_US.utf8")
 110                          (locale-category LC_ALL)
 111                          #:allow-other-keys)
 112   "Try to install LOCALE; emit a warning if that fails.  The main goal is to
 113 use a UTF-8 locale so that Guile correctly interprets UTF-8 file names.
 114
 115 This phase must typically happen after 'set-paths' so that $LOCPATH has a
 116 chance to be set."
 117   (catch 'system-error
 118     (lambda ()
 119       (setlocale locale-category locale)
 120
 121       ;; While we're at it, pass it to sub-processes.
 122       (setenv (locale-category->string locale-category) locale)
 123
 124       (format (current-error-port) "using '~a' locale for category ~s~%"
 125               locale (locale-category->string locale-category))
 126       #t)
 127     (lambda args
 128       ;; This is known to fail for instance in early bootstrap where locales
 129       ;; are not available.
 130       (format (current-error-port)
 131               "warning: failed to install '~a' locale: ~a~%"
 132               locale (strerror (system-error-errno args)))
 133       #t)))
 134
 135 (define* (unpack #:key source #:allow-other-keys)
 136   "Unpack SOURCE in the working directory, and change directory within the
 137 source.  When SOURCE is a directory, copy it in a sub-directory of the current
 138 working directory."
 139   (if (file-is-directory? source)
 140       (begin
 141         (mkdir "source")
 142         (chdir "source")
 143
 144         ;; Preserve timestamps (set to the Epoch) on the copied tree so that
 145         ;; things work deterministically.
 146         (copy-recursively source "."
 147                           #:keep-mtime? #t)
 148         #t)
 149       (and (if (string-suffix? ".zip" source)
 150                (zero? (system* "unzip" source))
 151                (zero? (system* "tar" "xvf" source)))
 152            (chdir (first-subdirectory ".")))))
 153
 154 ;; See <http://bugs.gnu.org/17840>.
 155 (define* (patch-usr-bin-file #:key native-inputs inputs
 156                              (patch-/usr/bin/file? #t)
 157                              #:allow-other-keys)
 158   "Patch occurrences of \"/usr/bin/file\" in all the executable 'configure'
 159 files found in the source tree.  This works around Libtool's Autoconf macros,
 160 which generates invocations of \"/usr/bin/file\" that are used to determine
 161 things like the ABI being used."
 162   (when patch-/usr/bin/file?
 163     (for-each (lambda (file)
 164                 (when (executable-file? file)
 165                   (patch-/usr/bin/file file)))
 166               (find-files "." "^configure$")))
 167   #t)
 168
 169 (define* (patch-source-shebangs #:key source #:allow-other-keys)
 170   "Patch shebangs in all source files; this includes non-executable
 171 files such as `.in' templates.  Most scripts honor $SHELL and
 172 $CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's
 173 `missing' script."
 174   (for-each patch-shebang
 175             (find-files "."
 176                         (lambda (file stat)
 177                           ;; Filter out symlinks.
 178                           (eq? 'regular (stat:type stat)))
 179                         #:stat lstat)))
 180
 181 (define (patch-generated-file-shebangs . rest)
 182   "Patch shebangs in generated files, including `SHELL' variables in
 183 makefiles."
 184   ;; Patch executable regular files, some of which might have been generated
 185   ;; by `configure'.
 186   (for-each patch-shebang
 187             (find-files "."
 188                         (lambda (file stat)
 189                           (and (eq? 'regular (stat:type stat))
 190                                (not (zero? (logand (stat:mode stat) #o100)))))
 191                         #:stat lstat))
 192
 193   ;; Patch `SHELL' in generated makefiles.
 194   (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")))
 195
 196 (define* (configure #:key build target native-inputs inputs outputs
 197                     (configure-flags '()) out-of-source?
 198                     #:allow-other-keys)
 199   (define (package-name)
 200     (let* ((out  (assoc-ref outputs "out"))
 201            (base (basename out))
 202            (dash (string-rindex base #\-)))
 203       ;; XXX: We'd rather use `package-name->name+version' or similar.
 204       (string-drop (if dash
 205                        (substring base 0 dash)
 206                        base)
 207                    (+ 1 (string-index base #\-)))))
 208
 209   (let* ((prefix     (assoc-ref outputs "out"))
 210          (bindir     (assoc-ref outputs "bin"))
 211          (libdir     (assoc-ref outputs "lib"))
 212          (includedir (assoc-ref outputs "include"))
 213          (docdir     (assoc-ref outputs "doc"))
 214          (bash       (or (and=> (assoc-ref (or native-inputs inputs) "bash")
 215                                 (cut string-append <> "/bin/bash"))
 216                          "/bin/sh"))
 217          (flags      `(,@(if target             ; cross building
 218                              '("CC_FOR_BUILD=gcc")
 219                              '())
 220                        ,(string-append "CONFIG_SHELL=" bash)
 221                        ,(string-append "SHELL=" bash)
 222                        ,(string-append "--prefix=" prefix)
 223                        "--enable-fast-install"    ; when using Libtool
 224
 225                        ;; Produce multiple outputs when specific output names
 226                        ;; are recognized.
 227                        ,@(if bindir
 228                               (list (string-append "--bindir=" bindir "/bin"))
 229                               '())
 230                        ,@(if libdir
 231                               (cons (string-append "--libdir=" libdir "/lib")
 232                                     (if includedir
 233                                         '()
 234                                         (list
 235                                          (string-append "--includedir="
 236                                                         libdir "/include"))))
 237                               '())
 238                        ,@(if includedir
 239                              (list (string-append "--includedir="
 240                                                   includedir "/include"))
 241                              '())
 242                        ,@(if docdir
 243                              (list (string-append "--docdir=" docdir
 244                                                   "/share/doc/" (package-name)))
 245                              '())
 246                        ,@(if build
 247                              (list (string-append "--build=" build))
 248                              '())
 249                        ,@(if target               ; cross building
 250                              (list (string-append "--host=" target))
 251                              '())
 252                        ,@configure-flags))
 253          (abs-srcdir (getcwd))
 254          (srcdir     (if out-of-source?
 255                          (string-append "../" (basename abs-srcdir))
 256                          ".")))
 257     (format #t "source directory: ~s (relative from build: ~s)~%"
 258             abs-srcdir srcdir)
 259     (if out-of-source?
 260         (begin
 261           (mkdir "../build")
 262           (chdir "../build")))
 263     (format #t "build directory: ~s~%" (getcwd))
 264     (format #t "configure flags: ~s~%" flags)
 265
 266     ;; Use BASH to reduce reliance on /bin/sh since it may not always be
 267     ;; reliable (see
 268     ;; <http://thread.gmane.org/gmane.linux.distributions.nixos/9748>
 269     ;; for a summary of the situation.)
 270     ;;
 271     ;; Call `configure' with a relative path.  Otherwise, GCC's build system
 272     ;; (for instance) records absolute source file names, which typically
 273     ;; contain the hash part of the `.drv' file, leading to a reference leak.
 274     (zero? (apply system* bash
 275                   (string-append srcdir "/configure")
 276                   flags))))
 277
 278 (define* (build #:key (make-flags '()) (parallel-build? #t)
 279                 #:allow-other-keys)
 280   (zero? (apply system* "make"
 281                 `(,@(if parallel-build?
 282                         `("-j" ,(number->string (parallel-job-count)))
 283                         '())
 284                   ,@make-flags))))
 285
 286 (define* (check #:key target (make-flags '()) (tests? (not target))
 287                 (test-target "check") (parallel-tests? #t)
 288                 #:allow-other-keys)
 289   (if tests?
 290       (zero? (apply system* "make" test-target
 291                     `(,@(if parallel-tests?
 292                             `("-j" ,(number->string (parallel-job-count)))
 293                             '())
 294                       ,@make-flags)))
 295       (begin
 296         (format #t "test suite not run~%")
 297         #t)))
 298
 299 (define* (install #:key (make-flags '()) #:allow-other-keys)
 300   (zero? (apply system* "make" "install" make-flags)))
 301
 302 (define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t)
 303                          #:allow-other-keys)
 304   (define (list-of-files dir)
 305     (map (cut string-append dir "/" <>)
 306          (or (scandir dir (lambda (f)
 307                             (let ((s (lstat (string-append dir "/" f))))
 308                               (eq? 'regular (stat:type s)))))
 309              '())))
 310
 311   (define bin-directories
 312     (match-lambda
 313      ((_ . dir)
 314       (list (string-append dir "/bin")
 315             (string-append dir "/sbin")))))
 316
 317   (define output-bindirs
 318     (append-map bin-directories outputs))
 319
 320   (define input-bindirs
 321     ;; Shebangs should refer to binaries of the target system---i.e., from
 322     ;; "inputs", not from "native-inputs".
 323     (append-map bin-directories inputs))
 324
 325   (when patch-shebangs?
 326     (let ((path (append output-bindirs input-bindirs)))
 327       (for-each (lambda (dir)
 328                   (let ((files (list-of-files dir)))
 329                     (for-each (cut patch-shebang <> path) files)))
 330                 output-bindirs)))
 331   #t)
 332
 333 (define* (strip #:key target outputs (strip-binaries? #t)
 334                 (strip-command (if target
 335                                    (string-append target "-strip")
 336                                    "strip"))
 337                 (objcopy-command (if target
 338                                      (string-append target "-objcopy")
 339                                      "objcopy"))
 340                 (strip-flags '("--strip-debug"
 341                                "--enable-deterministic-archives"))
 342                 (strip-directories '("lib" "lib64" "libexec"
 343                                      "bin" "sbin"))
 344                 #:allow-other-keys)
 345   (define debug-output
 346     ;; If an output is called "debug", then that's where debugging information
 347     ;; will be stored instead of being discarded.
 348     (assoc-ref outputs "debug"))
 349
 350   (define debug-file-extension
 351     ;; File name extension for debugging information.
 352     ".debug")
 353
 354   (define (debug-file file)
 355     ;; Return the name of the debug file for FILE, an absolute file name.
 356     ;; Once installed in the user's profile, it is in $PROFILE/lib/debug/FILE,
 357     ;; which is where GDB looks for it (info "(gdb) Separate Debug Files").
 358     (string-append debug-output "/lib/debug/"
 359                    file debug-file-extension))
 360
 361   (define (make-debug-file file)
 362     ;; Create a file in DEBUG-OUTPUT containing the debugging info of FILE.
 363     (let ((debug (debug-file file)))
 364       (mkdir-p (dirname debug))
 365       (copy-file file debug)
 366       (and (zero? (system* strip-command "--only-keep-debug" debug))
 367            (begin
 368              (chmod debug #o400)
 369              #t))))
 370
 371   (define (add-debug-link file)
 372     ;; Add a debug link in FILE (info "(binutils) strip").
 373
 374     ;; `objcopy --add-gnu-debuglink' wants to have the target of the debug
 375     ;; link around so it can compute a CRC of that file (see the
 376     ;; `bfd_fill_in_gnu_debuglink_section' function.)  No reference to
 377     ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug
 378     ;; file.
 379     (zero? (system* objcopy-command "--enable-deterministic-archives"
 380                     (string-append "--add-gnu-debuglink="
 381                                    (debug-file file))
 382                     file)))
 383
 384   (define (strip-dir dir)
 385     (format #t "stripping binaries in ~s with ~s and flags ~s~%"
 386             dir strip-command strip-flags)
 387     (when debug-output
 388       (format #t "debugging output written to ~s using ~s~%"
 389               debug-output objcopy-command))
 390
 391     (for-each (lambda (file)
 392                 (and (file-exists? file)          ;discard dangling symlinks
 393                      (or (elf-file? file) (ar-file? file))
 394                      (or (not debug-output)
 395                          (make-debug-file file))
 396                      (zero? (apply system* strip-command
 397                                    (append strip-flags (list file))))
 398                      (or (not debug-output)
 399                          (add-debug-link file))))
 400               (find-files dir)))
 401
 402   (or (not strip-binaries?)
 403       (every strip-dir
 404              (append-map (match-lambda
 405                           ((_ . dir)
 406                            (filter-map (lambda (d)
 407                                          (let ((sub (string-append dir "/" d)))
 408                                            (and (directory-exists? sub) sub)))
 409                                        strip-directories)))
 410                          outputs))))
 411
 412 (define* (validate-runpath #:key
 413                            (validate-runpath? #t)
 414                            (elf-directories '("lib" "lib64" "libexec"
 415                                               "bin" "sbin"))
 416                            outputs #:allow-other-keys)
 417   "When VALIDATE-RUNPATH? is true, validate that all the ELF files in
 418 ELF-DIRECTORIES have their dependencies found in their 'RUNPATH'.
 419
 420 Since the ELF parser needs to have a copy of files in memory, better run this
 421 phase after stripping."
 422   (define (sub-directory parent)
 423     (lambda (directory)
 424       (let ((directory (string-append parent "/" directory)))
 425         (and (directory-exists? directory) directory))))
 426
 427   (define (validate directory)
 428     (define (file=? file1 file2)
 429       (let ((st1 (stat file1))
 430             (st2 (stat file2)))
 431         (= (stat:ino st1) (stat:ino st2))))
 432
 433     ;; There are always symlinks from '.so' to '.so.1' and so on, so delete
 434     ;; duplicates.
 435     (let ((files (delete-duplicates (find-files directory (lambda (file stat)
 436                                                             (elf-file? file)))
 437                                     file=?)))
 438       (format (current-error-port)
 439               "validating RUNPATH of ~a binaries in ~s...~%"
 440               (length files) directory)
 441       (every* validate-needed-in-runpath files)))
 442
 443   (if validate-runpath?
 444       (let ((dirs (append-map (match-lambda
 445                                 (("debug" . _)
 446                                  ;; The "debug" output is full of ELF files
 447                                  ;; that are not worth checking.
 448                                  '())
 449                                 ((name . output)
 450                                  (filter-map (sub-directory output)
 451                                              elf-directories)))
 452                               outputs)))
 453         (every* validate dirs))
 454       (begin
 455         (format (current-error-port) "skipping RUNPATH validation~%")
 456         #t)))
 457
 458 (define* (validate-documentation-location #:key outputs
 459                                           #:allow-other-keys)
 460   "Documentation should go to 'share/info' and 'share/man', not just 'info/'
 461 and 'man/'.  This phase moves directories to the right place if needed."
 462   (define (validate-sub-directory output sub-directory)
 463     (let ((directory (string-append output "/" sub-directory)))
 464       (when (directory-exists? directory)
 465         (let ((target (string-append output "/share/" sub-directory)))
 466           (format #t "moving '~a' to '~a'~%" directory target)
 467           (mkdir-p (dirname target))
 468           (rename-file directory target)))))
 469
 470   (define (validate-output output)
 471     (for-each (cut validate-sub-directory output <>)
 472               '("man" "info")))
 473
 474   (match outputs
 475     (((names . directories) ...)
 476      (for-each validate-output directories)))
 477   #t)
 478
 479 (define* (compress-documentation #:key outputs
 480                                  (compress-documentation? #t)
 481                                  (documentation-compressor "gzip")
 482                                  (documentation-compressor-flags
 483                                   '("--best" "--no-name"))
 484                                  (compressed-documentation-extension ".gz")
 485                                  #:allow-other-keys)
 486   "When COMPRESS-DOCUMENTATION? is true, compress man pages and Info files
 487 found in OUTPUTS using DOCUMENTATION-COMPRESSOR, called with
 488 DOCUMENTATION-COMPRESSOR-FLAGS."
 489   (define (retarget-symlink link)
 490     (let ((target (readlink link)))
 491       (delete-file link)
 492       (symlink (string-append target compressed-documentation-extension)
 493                link)))
 494
 495   (define (has-links? file)
 496     ;; Return #t if FILE has hard links.
 497     (> (stat:nlink (lstat file)) 1))
 498
 499   (define (maybe-compress-directory directory regexp)
 500     (or (not (directory-exists? directory))
 501         (match (find-files directory regexp)
 502           (()                                     ;nothing to compress
 503            #t)
 504           ((files ...)                            ;one or more files
 505            (format #t
 506                    "compressing documentation in '~a' with ~s and flags ~s~%"
 507                    directory documentation-compressor
 508                    documentation-compressor-flags)
 509            (call-with-values
 510                (lambda ()
 511                  (partition symbolic-link? files))
 512              (lambda (symlinks regular-files)
 513                ;; Compress the non-symlink files, and adjust symlinks to refer
 514                ;; to the compressed files.  Leave files that have hard links
 515                ;; unchanged ('gzip' would refuse to compress them anyway.)
 516                (and (zero? (apply system* documentation-compressor
 517                                   (append documentation-compressor-flags
 518                                           (remove has-links? regular-files))))
 519                     (every retarget-symlink
 520                            (filter (cut string-match regexp <>)
 521                                    symlinks)))))))))
 522
 523   (define (maybe-compress output)
 524     (and (maybe-compress-directory (string-append output "/share/man")
 525                                    "\\.[0-9]+$")
 526          (maybe-compress-directory (string-append output "/share/info")
 527                                    "\\.info(-[0-9]+)?$")))
 528
 529   (if compress-documentation?
 530       (match outputs
 531         (((names . directories) ...)
 532          (every maybe-compress directories)))
 533       (begin
 534         (format #t "not compressing documentation~%")
 535         #t)))
 536
 537 (define* (delete-info-dir-file #:key outputs #:allow-other-keys)
 538   "Delete any 'share/info/dir' file from OUTPUTS."
 539   (for-each (match-lambda
 540           ((output . directory)
 541            (let ((info-dir-file (string-append directory "/share/info/dir")))
 542              (when (file-exists? info-dir-file)
 543                (delete-file info-dir-file)))))
 544             outputs)
 545   #t)
 546
 547
 548 (define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys)
 549   "Replace any references to executables in '.desktop' files with their
 550 absolute file names."
 551   (define bin-directories
 552     (append-map (match-lambda
 553                   ((_ . directory)
 554                    (list (string-append directory "/bin")
 555                          (string-append directory "/sbin"))))
 556                 outputs))
 557
 558   (define (which program)
 559     (or (search-path bin-directories program)
 560         (begin
 561           (format (current-error-port)
 562                   "warning: '.desktop' file refers to '~a', \
 563 which cannot be found~%"
 564                   program)
 565           program)))
 566
 567   (for-each (match-lambda
 568               ((_ . directory)
 569                (let ((applications (string-append directory
 570                                                   "/share/applications")))
 571                  (when (directory-exists? applications)
 572                    (let ((files (find-files applications "\\.desktop$")))
 573                      (format #t "adjusting ~a '.desktop' files in ~s~%"
 574                              (length files) applications)
 575
 576                      ;; '.desktop' files contain translations and are always
 577                      ;; UTF-8-encoded.
 578                      (with-fluids ((%default-port-encoding "UTF-8"))
 579                        (substitute* files
 580                          (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
 581                           (string-append "Exec=" (which binary) rest))
 582                          (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
 583                           (string-append "TryExec="
 584                                          (which binary) rest)))))))))
 585             outputs)
 586   #t)
 587
 588 (define %standard-phases
 589   ;; Standard build phases, as a list of symbol/procedure pairs.
 590   (let-syntax ((phases (syntax-rules ()
 591                          ((_ p ...) `((p . ,p) ...)))))
 592     (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack
 593             patch-usr-bin-file
 594             patch-source-shebangs configure patch-generated-file-shebangs
 595             build check install
 596             patch-shebangs strip
 597             validate-runpath
 598             validate-documentation-location
 599             delete-info-dir-file
 600             patch-dot-desktop-files
 601             compress-documentation)))
 602
 603 \f
 604 (define* (gnu-build #:key (source #f) (outputs #f) (inputs #f)
 605                     (phases %standard-phases)
 606                     #:allow-other-keys
 607                     #:rest args)
 608   "Build from SOURCE to OUTPUTS, using INPUTS, and by running all of PHASES
 609 in order.  Return #t if all the PHASES succeeded, #f otherwise."
 610   (define (elapsed-time end start)
 611     (let ((diff (time-difference end start)))
 612       (+ (time-second diff)
 613          (/ (time-nanosecond diff) 1e9))))
 614
 615   (setvbuf (current-output-port) _IOLBF)
 616   (setvbuf (current-error-port) _IOLBF)
 617
 618   ;; Encoding/decoding errors shouldn't be silent.
 619   (fluid-set! %default-port-conversion-strategy 'error)
 620
 621   ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
 622   ;; PHASES can pick the keyword arguments it's interested in.
 623   (every (match-lambda
 624           ((name . proc)
 625            (let ((start (current-time time-monotonic)))
 626              (format #t "starting phase `~a'~%" name)
 627              (let ((result (apply proc args))
 628                    (end    (current-time time-monotonic)))
 629                (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
 630                        name result
 631                        (elapsed-time end start))
 632
 633                ;; Dump the environment variables as a shell script, for handy debugging.
 634                (system "export > $NIX_BUILD_TOP/environment-variables")
 635                result))))
 636          phases))