guix/build-system/gnu.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 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-system gnu)
  20   #:use-module (guix store)
  21   #:use-module (guix utils)
  22   #:use-module (guix derivations)
  23   #:use-module (guix search-paths)
  24   #:use-module (guix build-system)
  25   #:use-module (guix packages)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (ice-9 match)
  28   #:export (%gnu-build-system-modules
  29             gnu-build
  30             gnu-build-system
  31             standard-packages
  32             package-with-explicit-inputs
  33             package-with-extra-configure-variable
  34             static-libgcc-package
  35             static-package
  36             dist-package
  37             package-with-restricted-references))
  38
  39 ;; Commentary:
  40 ;;
  41 ;; Standard build procedure for packages using the GNU Build System or
  42 ;; something compatible ("./configure && make && make install").
  43 ;;
  44 ;; Code:
  45
  46 (define %gnu-build-system-modules
  47   ;; Build-side modules imported and used by default.
  48   '((guix build gnu-build-system)
  49     (guix build utils)
  50     (guix build gremlin)
  51     (guix elf)))
  52
  53 (define %default-modules
  54   ;; Modules in scope in the build-side environment.
  55   '((guix build gnu-build-system)
  56     (guix build utils)))
  57
  58 (define* (package-with-explicit-inputs p inputs
  59                                        #:optional
  60                                        (loc (current-source-location))
  61                                        #:key (native-inputs '())
  62                                        guile)
  63   "Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take INPUTS and
  64 NATIVE-INPUTS as explicit inputs instead of the implicit default, and return
  65 it.  INPUTS and NATIVE-INPUTS can be either input lists or thunks; in the
  66 latter case, they will be called in a context where the `%current-system' and
  67 `%current-target-system' are suitably parametrized.  Use GUILE to run the
  68 builder, or the distro's final Guile when GUILE is #f."
  69   (define inputs* inputs)
  70   (define native-inputs* native-inputs)
  71
  72   (define (call inputs)
  73     (if (procedure? inputs)
  74         (inputs)
  75         inputs))
  76
  77   (define (duplicate-filter inputs)
  78     (let ((names (match (call inputs)
  79                    (((name _ ...) ...)
  80                     name))))
  81       (lambda (inputs)
  82         (fold alist-delete inputs names))))
  83
  84   (let loop ((p p))
  85     (define rewritten-input
  86       (memoize
  87        (match-lambda
  88         ((name (? package? p) sub-drv ...)
  89          ;; XXX: Check whether P's build system knows #:implicit-inputs, for
  90          ;; things like `cross-pkg-config'.
  91          (if (eq? (package-build-system p) gnu-build-system)
  92              (cons* name (loop p) sub-drv)
  93              (cons* name p sub-drv)))
  94         (x x))))
  95
  96     (package (inherit p)
  97       (location (if (pair? loc) (source-properties->location loc) loc))
  98       (arguments
  99        (let ((args (package-arguments p)))
 100          `(#:guile ,guile
 101            #:implicit-inputs? #f
 102            ,@args)))
 103       (replacement
 104        (let ((replacement (package-replacement p)))
 105          (and replacement
 106               (package-with-explicit-inputs replacement inputs loc
 107                                             #:native-inputs
 108                                             native-inputs
 109                                             #:guile guile))))
 110       (native-inputs
 111        (let ((filtered (duplicate-filter native-inputs*)))
 112         `(,@(call native-inputs*)
 113           ,@(map rewritten-input
 114                  (filtered (package-native-inputs p))))))
 115       (propagated-inputs
 116        (map rewritten-input
 117             (package-propagated-inputs p)))
 118       (inputs
 119        (let ((filtered (duplicate-filter inputs*)))
 120          `(,@(call inputs*)
 121            ,@(map rewritten-input
 122                   (filtered (package-inputs p)))))))))
 123
 124 (define (package-with-extra-configure-variable p variable value)
 125   "Return a version of P with VARIABLE=VALUE specified as an extra `configure'
 126 flag, recursively.  An example is LDFLAGS=-static.  If P already has configure
 127 flags for VARIABLE, the associated value is augmented."
 128   (let loop ((p p))
 129     (define (rewritten-inputs inputs)
 130       (map (match-lambda
 131             ((name (? package? p) sub ...)
 132              `(,name ,(loop p) ,@sub))
 133             (input input))
 134            inputs))
 135
 136     (package (inherit p)
 137       (arguments
 138        (let ((args (package-arguments p)))
 139          (substitute-keyword-arguments args
 140            ((#:configure-flags flags)
 141             (let* ((var= (string-append variable "="))
 142                    (len  (string-length var=)))
 143               `(cons ,(string-append var= value)
 144                      (map (lambda (flag)
 145                             (if (string-prefix? ,var= flag)
 146                                 (string-append
 147                                  ,(string-append var= value " ")
 148                                  (substring flag ,len))
 149                                 flag))
 150                           ,flags)))))))
 151       (replacement
 152        (let ((replacement (package-replacement p)))
 153          (and replacement
 154               (package-with-extra-configure-variable replacement
 155                                                      variable value))))
 156       (inputs (rewritten-inputs (package-inputs p)))
 157       (propagated-inputs (rewritten-inputs (package-propagated-inputs p))))))
 158
 159 (define (static-libgcc-package p)
 160   "A version of P linked with `-static-gcc'."
 161   (package-with-extra-configure-variable p "LDFLAGS" "-static-libgcc"))
 162
 163 (define* (static-package p #:optional (loc (current-source-location))
 164                          #:key (strip-all? #t))
 165   "Return a statically-linked version of package P.  If STRIP-ALL? is true,
 166 use `--strip-all' as the arguments to `strip'."
 167   (package (inherit p)
 168     (location (source-properties->location loc))
 169     (arguments
 170      (let ((a (default-keyword-arguments (package-arguments p)
 171                 '(#:configure-flags '()
 172                   #:strip-flags '("--strip-debug")))))
 173        (substitute-keyword-arguments a
 174          ((#:configure-flags flags)
 175           `(cons* "--disable-shared" "LDFLAGS=-static" ,flags))
 176          ((#:strip-flags flags)
 177           (if strip-all?
 178               ''("--strip-all")
 179               flags)))))
 180     (replacement (and=> (package-replacement p) static-package))))
 181
 182 (define* (dist-package p source)
 183   "Return a package that runs takes source files from the SOURCE directory,
 184 runs `make distcheck' and whose result is one or more source tarballs."
 185   (let ((s source))
 186     (package (inherit p)
 187       (name (string-append (package-name p) "-dist"))
 188       (source s)
 189       (arguments
 190        ;; Use the right phases and modules.
 191        (let* ((args (default-keyword-arguments (package-arguments p)
 192                       `(#:phases #f
 193                         #:modules ,%default-modules
 194                         #:imported-modules ,%gnu-build-system-modules))))
 195          (substitute-keyword-arguments args
 196            ((#:modules modules)
 197             `((guix build gnu-dist)
 198               ,@modules))
 199            ((#:imported-modules modules)
 200             `((guix build gnu-dist)
 201               ,@modules))
 202            ((#:phases _)
 203             '%dist-phases))))
 204       (native-inputs
 205        ;; Add autotools & co. as inputs.
 206        (let ((ref (lambda (module var)
 207                     (module-ref (resolve-interface module) var))))
 208          `(,@(package-native-inputs p)
 209            ("autoconf" ,(ref '(gnu packages autotools) 'autoconf))
 210            ("automake" ,(ref '(gnu packages autotools) 'automake))
 211            ("libtool"  ,(ref '(gnu packages autotools) 'libtool))
 212            ("gettext"  ,(ref '(gnu packages gettext) 'gnu-gettext))
 213            ("texinfo"  ,(ref '(gnu packages texinfo) 'texinfo))))))))
 214
 215 (define (package-with-restricted-references p refs)
 216   "Return a package whose outputs are guaranteed to only refer to the packages
 217 listed in REFS."
 218   (if (eq? (package-build-system p) gnu-build-system) ; XXX: dirty
 219       (package (inherit p)
 220         (arguments `(#:allowed-references ,refs
 221                      ,@(package-arguments p))))
 222       p))
 223
 224 \f
 225 (define (standard-packages)
 226   "Return the list of (NAME PACKAGE OUTPUT) or (NAME PACKAGE) tuples of
 227 standard packages used as implicit inputs of the GNU build system."
 228
 229   ;; Resolve (gnu packages commencement) lazily to hide circular dependency.
 230   (let ((distro (resolve-module '(gnu packages commencement))))
 231     (module-ref distro '%final-inputs)))
 232
 233 (define* (lower name
 234                 #:key source inputs native-inputs outputs target
 235                 (implicit-inputs? #t) (implicit-cross-inputs? #t)
 236                 (strip-binaries? #t) system
 237                 #:allow-other-keys
 238                 #:rest arguments)
 239   "Return a bag for NAME from the given arguments."
 240   (define private-keywords
 241     `(#:source #:inputs #:native-inputs #:outputs
 242       #:implicit-inputs? #:implicit-cross-inputs?
 243       ,@(if target '() '(#:target))))
 244
 245   (bag
 246     (name name)
 247     (system system) (target target)
 248     (build-inputs `(,@(if source
 249                           `(("source" ,source))
 250                           '())
 251                     ,@native-inputs
 252                     ,@(if (and target implicit-cross-inputs?)
 253                           (standard-cross-packages target 'host)
 254                           '())
 255                     ,@(if implicit-inputs?
 256                           (standard-packages)
 257                           '())))
 258     (host-inputs inputs)
 259
 260     ;; The cross-libc is really a target package, but for bootstrapping
 261     ;; reasons, we can't put it in 'host-inputs'.  Namely, 'cross-gcc' is a
 262     ;; native package, so it would end up using a "native" variant of
 263     ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages
 264     ;; would use a target variant (built with 'gnu-cross-build'.)
 265     (target-inputs (if (and target implicit-cross-inputs?)
 266                        (standard-cross-packages target 'target)
 267                        '()))
 268     (outputs (if strip-binaries?
 269                  outputs
 270                  (delete "debug" outputs)))
 271     (build (if target gnu-cross-build gnu-build))
 272     (arguments (strip-keyword-arguments private-keywords arguments))))
 273
 274 (define* (gnu-build store name input-drvs
 275                     #:key (guile #f)
 276                     (outputs '("out"))
 277                     (search-paths '())
 278                     (configure-flags ''())
 279                     (make-flags ''())
 280                     (out-of-source? #f)
 281                     (tests? #t)
 282                     (test-target "check")
 283                     (parallel-build? #t)
 284                     (parallel-tests? #t)
 285                     (patch-shebangs? #t)
 286                     (strip-binaries? #t)
 287                     (strip-flags ''("--strip-debug"))
 288                     (strip-directories ''("lib" "lib64" "libexec"
 289                                           "bin" "sbin"))
 290                     (validate-runpath? #t)
 291                     (phases '%standard-phases)
 292                     (locale "en_US.UTF-8")
 293                     (system (%current-system))
 294                     (imported-modules %gnu-build-system-modules)
 295                     (modules %default-modules)
 296                     (substitutable? #t)
 297                     allowed-references)
 298   "Return a derivation called NAME that builds from tarball SOURCE, with
 299 input derivation INPUTS, using the usual procedure of the GNU Build
 300 System.  The builder is run with GUILE, or with the distro's final Guile
 301 package if GUILE is #f or omitted.
 302
 303 The builder is run in a context where MODULES are used; IMPORTED-MODULES
 304 specifies modules not provided by Guile itself that must be imported in
 305 the builder's environment, from the host.  Note that we distinguish
 306 between both, because for Guile's own modules like (ice-9 foo), we want
 307 to use GUILE's own version of it, rather than import the user's one,
 308 which could lead to gratuitous input divergence.
 309
 310 SUBSTITUTABLE? determines whether users may be able to use substitutes of the
 311 returned derivations, or whether they should always build it locally.
 312
 313 ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs
 314 are allowed to refer to."
 315   (define canonicalize-reference
 316     (match-lambda
 317      ((? package? p)
 318       (derivation->output-path (package-derivation store p system
 319                                                    #:graft? #f)))
 320      (((? package? p) output)
 321       (derivation->output-path (package-derivation store p system
 322                                                    #:graft? #f)
 323                                output))
 324      ((? string? output)
 325       output)))
 326
 327   (define builder
 328     `(begin
 329        (use-modules ,@modules)
 330        (gnu-build #:source ,(match (assoc-ref input-drvs "source")
 331                               (((? derivation? source))
 332                                (derivation->output-path source))
 333                               ((source)
 334                                source)
 335                               (source
 336                                source))
 337                   #:system ,system
 338                   #:outputs %outputs
 339                   #:inputs %build-inputs
 340                   #:search-paths ',(map search-path-specification->sexp
 341                                         search-paths)
 342                   #:phases ,phases
 343                   #:locale ,locale
 344                   #:configure-flags ,configure-flags
 345                   #:make-flags ,make-flags
 346                   #:out-of-source? ,out-of-source?
 347                   #:tests? ,tests?
 348                   #:test-target ,test-target
 349                   #:parallel-build? ,parallel-build?
 350                   #:parallel-tests? ,parallel-tests?
 351                   #:patch-shebangs? ,patch-shebangs?
 352                   #:strip-binaries? ,strip-binaries?
 353                   #:validate-runpath? ,validate-runpath?
 354                   #:strip-flags ,strip-flags
 355                   #:strip-directories ,strip-directories)))
 356
 357   (define guile-for-build
 358     (match guile
 359       ((? package?)
 360        (package-derivation store guile system #:graft? #f))
 361       (#f                                         ; the default
 362        (let* ((distro (resolve-interface '(gnu packages commencement)))
 363               (guile  (module-ref distro 'guile-final)))
 364          (package-derivation store guile system
 365                              #:graft? #f)))))
 366
 367   (build-expression->derivation store name builder
 368                                 #:system system
 369                                 #:inputs input-drvs
 370                                 #:outputs outputs
 371                                 #:modules imported-modules
 372
 373                                 ;; XXX: Update when
 374                                 ;; <http://bugs.gnu.org/18747> is fixed.
 375                                 #:local-build? (not substitutable?)
 376
 377                                 #:allowed-references
 378                                 (and allowed-references
 379                                      (map canonicalize-reference
 380                                           allowed-references))
 381                                 #:guile-for-build guile-for-build))
 382
 383 \f
 384 ;;;
 385 ;;; Cross-compilation.
 386 ;;;
 387
 388 (define standard-cross-packages
 389   (memoize
 390    (lambda (target kind)
 391      "Return the list of name/package tuples to cross-build for TARGET.  KIND
 392 is one of `host' or `target'."
 393      (let* ((cross     (resolve-interface '(gnu packages cross-base)))
 394             (gcc       (module-ref cross 'cross-gcc))
 395             (binutils  (module-ref cross 'cross-binutils))
 396             (libc      (module-ref cross 'cross-libc)))
 397        (case kind
 398          ((host)
 399           `(("cross-gcc" ,(gcc target
 400                                (binutils target)
 401                                (libc target)))
 402             ("cross-binutils" ,(binutils target))))
 403          ((target)
 404           `(("cross-libc" ,(libc target)))))))))
 405
 406 (define* (gnu-cross-build store name
 407                           #:key
 408                           target native-drvs target-drvs
 409                           (guile #f)
 410                           source
 411                           (outputs '("out"))
 412                           (search-paths '())
 413                           (native-search-paths '())
 414
 415                           (configure-flags ''())
 416                           (make-flags ''())
 417                           (out-of-source? #f)
 418                           (tests? #f)             ; nothing can be done
 419                           (test-target "check")
 420                           (parallel-build? #t) (parallel-tests? #t)
 421                           (patch-shebangs? #t)
 422                           (strip-binaries? #t)
 423                           (strip-flags ''("--strip-debug"))
 424                           (strip-directories ''("lib" "lib64" "libexec"
 425                                                 "bin" "sbin"))
 426                           (validate-runpath? #t)
 427                           (phases '%standard-phases)
 428                           (locale "en_US.UTF-8")
 429                           (system (%current-system))
 430                           (imported-modules %gnu-build-system-modules)
 431                           (modules %default-modules)
 432                           (substitutable? #t)
 433                           allowed-references)
 434   "Cross-build NAME for TARGET, where TARGET is a GNU triplet.  INPUTS are
 435 cross-built inputs, and NATIVE-INPUTS are inputs that run on the build
 436 platform."
 437   (define canonicalize-reference
 438     (match-lambda
 439      ((? package? p)
 440       (derivation->output-path (package-cross-derivation store p system)))
 441      (((? package? p) output)
 442       (derivation->output-path (package-cross-derivation store p system)
 443                                output))
 444      ((? string? output)
 445       output)))
 446
 447   (define builder
 448     `(begin
 449        (use-modules ,@modules)
 450
 451        (let ()
 452          (define %build-host-inputs
 453            ',(map (match-lambda
 454                    ((name (? derivation? drv) sub ...)
 455                     `(,name . ,(apply derivation->output-path drv sub)))
 456                    ((name path)
 457                     `(,name . ,path)))
 458                   native-drvs))
 459
 460          (define %build-target-inputs
 461            ',(map (match-lambda
 462                    ((name (? derivation? drv) sub ...)
 463                     `(,name . ,(apply derivation->output-path drv sub)))
 464                    ((name (? package? pkg) sub ...)
 465                     (let ((drv (package-cross-derivation store pkg
 466                                                          target system)))
 467                       `(,name . ,(apply derivation->output-path drv sub))))
 468                    ((name path)
 469                     `(,name . ,path)))
 470                   target-drvs))
 471
 472          (gnu-build #:source ,(match (assoc-ref native-drvs "source")
 473                                 (((? derivation? source))
 474                                  (derivation->output-path source))
 475                                 ((source)
 476                                  source)
 477                                 (source
 478                                  source))
 479                     #:system ,system
 480                     #:target ,target
 481                     #:outputs %outputs
 482                     #:inputs %build-target-inputs
 483                     #:native-inputs %build-host-inputs
 484                     #:search-paths ',(map search-path-specification->sexp
 485                                           search-paths)
 486                     #:native-search-paths ',(map
 487                                              search-path-specification->sexp
 488                                              native-search-paths)
 489                     #:phases ,phases
 490                     #:locale ,locale
 491                     #:configure-flags ,configure-flags
 492                     #:make-flags ,make-flags
 493                     #:out-of-source? ,out-of-source?
 494                     #:tests? ,tests?
 495                     #:test-target ,test-target
 496                     #:parallel-build? ,parallel-build?
 497                     #:parallel-tests? ,parallel-tests?
 498                     #:patch-shebangs? ,patch-shebangs?
 499                     #:strip-binaries? ,strip-binaries?
 500                     #:validate-runpath? ,validate-runpath?
 501                     #:strip-flags ,strip-flags
 502                     #:strip-directories ,strip-directories))))
 503
 504   (define guile-for-build
 505     (match guile
 506       ((? package?)
 507        (package-derivation store guile system #:graft? #f))
 508       (#f                                         ; the default
 509        (let* ((distro (resolve-interface '(gnu packages commencement)))
 510               (guile  (module-ref distro 'guile-final)))
 511          (package-derivation store guile system #:graft? #f)))))
 512
 513   (build-expression->derivation store name builder
 514                                 #:system system
 515                                 #:inputs (append native-drvs target-drvs)
 516                                 #:outputs outputs
 517                                 #:modules imported-modules
 518
 519                                 ;; XXX: Update when
 520                                 ;; <http://bugs.gnu.org/18747> is fixed.
 521                                 #:local-build? (not substitutable?)
 522
 523                                 #:allowed-references
 524                                 (and allowed-references
 525                                      (map canonicalize-reference
 526                                           allowed-references))
 527                                 #:guile-for-build guile-for-build))
 528
 529 (define gnu-build-system
 530   (build-system
 531     (name 'gnu)
 532     (description
 533      "The GNU Build System—i.e., ./configure && make && make install")
 534     (lower lower)))