guix/build-system/gnu.scm

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