From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp12.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms5.migadu.com with LMTPS id gPD6AoWTmmNWbgAAbAwnHQ (envelope-from ) for ; Thu, 15 Dec 2022 04:24:53 +0100 Received: from aspmx1.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp12.migadu.com with LMTPS id MFjeAoWTmmPCAAAAauVa8A (envelope-from ) for ; Thu, 15 Dec 2022 04:24:53 +0100 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 5D886367FC for ; Thu, 15 Dec 2022 04:24:52 +0100 (CET) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1p5equ-00038H-6s; Wed, 14 Dec 2022 22:24:08 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1p5eqq-00035M-0a for bug-guix@gnu.org; Wed, 14 Dec 2022 22:24:04 -0500 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1p5eqo-00024h-Lm; Wed, 14 Dec 2022 22:24:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1p5eqo-0004pQ-3a; Wed, 14 Dec 2022 22:24:02 -0500 X-Loop: help-debbugs@gnu.org Subject: bug#60056: [PATCH RFC 1/6] build: Add gnu-build-system v2. References: <87h6xy4tmz.fsf@gmail.com> In-Reply-To: <87h6xy4tmz.fsf@gmail.com> Resent-From: Maxim Cournoyer Original-Sender: "Debbugs-submit" Resent-CC: ludo@gnu.org, bug-guix@gnu.org Resent-Date: Thu, 15 Dec 2022 03:24:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 60056 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: 60056@debbugs.gnu.org Cc: Maxim Cournoyer , ludo@gnu.org X-Debbugs-Original-Xcc: ludo@gnu.org Received: via spool by 60056-submit@debbugs.gnu.org id=B60056.167107462718489 (code B ref 60056); Thu, 15 Dec 2022 03:24:02 +0000 Received: (at 60056) by debbugs.gnu.org; 15 Dec 2022 03:23:47 +0000 Received: from localhost ([127.0.0.1]:42264 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1p5eqW-0004o5-Uq for submit@debbugs.gnu.org; Wed, 14 Dec 2022 22:23:47 -0500 Received: from mail-qt1-f169.google.com ([209.85.160.169]:33652) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1p5eqS-0004nu-Im for 60056@debbugs.gnu.org; Wed, 14 Dec 2022 22:23:44 -0500 Received: by mail-qt1-f169.google.com with SMTP id fu10so4299670qtb.0 for <60056@debbugs.gnu.org>; Wed, 14 Dec 2022 19:23:40 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=4qds0p1G+OhQ+NMJVX2019y4BL6NOaNjDNyrfj/XJZ4=; b=lhzly4xD/9PTGVE8b3CYJ7ZFq8UugRrmzQ9lYGUoZ4ERMLDdPayFHPVbyK7Ux0UJnF p95JynLPskJ45fu8+L4S0KyqwINI4rymu9D4AQhEpAS5IOXO5UewKANLsu4xTESQeK4I Mn4y7VT82+UX9Zon7NLSPzdkh2Hx0SdgR6Q2KEaejVwdmdaOHCQiR3HNcDomGfy/NCBo ScgOSNKMJC7VHjavrFmL8PHYlA5Uj5s7z3QT8fHWYj5C235mMNArM2rGDZYyff3oy4LW iacagug+FD3BKZBMyBMCSZHk5qOX+1OYbpVDM+znkXZIioWz6u3sCtycE4tM2t2TTOfN pLhA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=4qds0p1G+OhQ+NMJVX2019y4BL6NOaNjDNyrfj/XJZ4=; b=PHLo9WAzEOexLTw8yiHgRsD8W/OVuSkzHtJei+Wge7JxL2ybd4CPKT4n1DQMM/8q0y cff1fA/ljv65rgu5DM/2BSFAfYbZmXcZNVJpWK4pyTVMntxjIsQvPbGCxTlHZlxsW5z7 3yc7tn5jpyAtDWHl/NZntMmGIoFIMiuhCrKxUagUoCxMH2b7uD5JVxag2yxcSaLF+T0x PGifiOFYDSDYa5AClbFV6GSxqB3/2qT/aeDIyk7nvGrbqYPYViLRtNtZUg7hlpkE7AkI og/W9av+NJJ6NC/kuLlGlkJhTTy7ulVP6WIXjJow3lLTJVssgGWnP/kDAwiXsXM5Ik1p 0B+w== X-Gm-Message-State: ANoB5pmYVrZXO5U3asVL/zNBC+FzB+GPSRz86GTsZ+6q9oG0Gn+kTNBI JOVKUeRTe8/OvSQ51unFbt36p60DPCGuKB40 X-Google-Smtp-Source: AA0mqf6XM7pTT2NrT0xEYi2W0tZOPX/COYufe1J9ZnTe2P9hvq14NTbXKWUTTQeCOSvZ+6UEhHAXSA== X-Received: by 2002:a05:622a:17c7:b0:3a7:e9a1:b83a with SMTP id u7-20020a05622a17c700b003a7e9a1b83amr42092818qtk.15.1671074613162; Wed, 14 Dec 2022 19:23:33 -0800 (PST) Received: from localhost.localdomain (dsl-10-129-63.b2b2c.ca. [72.10.129.63]) by smtp.gmail.com with ESMTPSA id c13-20020ac853cd000000b003a7e4129f83sm2763101qtq.85.2022.12.14.19.23.31 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 14 Dec 2022 19:23:32 -0800 (PST) From: Maxim Cournoyer Date: Wed, 14 Dec 2022 22:23:23 -0500 Message-Id: <20221215032328.3368-1-maxim.cournoyer@gmail.com> X-Mailer: git-send-email 2.38.1 MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guix@gnu.org List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guix-bounces+larch=yhetil.org@gnu.org Sender: bug-guix-bounces+larch=yhetil.org@gnu.org X-Migadu-Country: US X-Migadu-Flow: FLOW_IN ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1671074692; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=XAA8x762tRK35jgjsKaRIfDRyS1Z6ZBl6cZEZUgVZcs=; b=V/L7FDCDWI7K9k5VbF5mIalz7IwxMKseTEeNmNbH36I/9JhY/ylQneSlmRzpB97g0lGlFg DPApv+c/s/AlSbhlEfbJV+NKBatp3EWk1w2pC5YX4ahU2qWBg+KmWWgj0jCmz8WhfYj3jI 21v7WF7Y2C3zbC8C1MDTs5JWLpxBtIH9p1hFJsjteBWH7MkzSPX3vO31sVsC6g7TfucTK2 vDWTlYPikzC5DrTA7URJm6DT9D215OV2vrBDjFV8SXpWDrxNFVGaXDZ6qD1bljn94sH1oX ItK2sgg9PXmDngZlQWx92f7CVOxjf4tBSLEYuz/n2RoNgTNTqKLqdHi8ai21jA== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=gmail.com header.s=20210112 header.b=lhzly4xD; spf=pass (aspmx1.migadu.com: domain of "bug-guix-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="bug-guix-bounces+larch=yhetil.org@gnu.org"; dmarc=fail reason="SPF not aligned (relaxed)" header.from=gmail.com (policy=none) ARC-Seal: i=1; s=key1; d=yhetil.org; t=1671074692; a=rsa-sha256; cv=none; b=j+Hy+PXgyiqXfOLQAoG45z4XgkGqwie7tVGMRtUsCwBPNd4ZuHN34tRkVHtOpVNUo7rCwo U+RrvDftSSdsFF320SjvTWrccC/hCnLphsEzesWi9RgEus7gG5sxceb72L8ZRsC6T6wm9i YmDd4KH+TR1zevtmYEjuagm79foTgBXenpYDPGq4hWEXoJCe3AZCxlqKOOlmfazM+DJlKJ XzkD4wt0xAkXgeVr7/Levl2y7zPbmB3D9650fWlueGEYxWwygb9E1Zu8aNhbj4sZu/SBZg 8AHK96DzsEG8DLlebwu9XugPb4E4BmzyMhMvBijdMf2WfhMJiWPLceoGWUKiPg== X-Migadu-Spam-Score: -1.88 X-Spam-Score: -1.88 X-Migadu-Queue-Id: 5D886367FC X-Migadu-Scanner: scn1.migadu.com Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=gmail.com header.s=20210112 header.b=lhzly4xD; spf=pass (aspmx1.migadu.com: domain of "bug-guix-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="bug-guix-bounces+larch=yhetil.org@gnu.org"; dmarc=fail reason="SPF not aligned (relaxed)" header.from=gmail.com (policy=none) X-TUID: 2vbDAXeM/LxK * guix/build/gnu-build-system2.scm: New file. * Makefile.am (MODULES): Register it. * guix/build-system/gnu2.scm: Use it. --- Makefile.am | 2 + guix/build-system/gnu2.scm | 580 +++++++++++++++++++ guix/build/gnu-build-system2.scm | 937 +++++++++++++++++++++++++++++++ 3 files changed, 1519 insertions(+) create mode 100644 guix/build-system/gnu2.scm create mode 100644 guix/build/gnu-build-system2.scm diff --git a/Makefile.am b/Makefile.am index b54288c0fc..a331385aa1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -159,6 +159,7 @@ MODULES = \ guix/build-system/copy.scm \ guix/build-system/glib-or-gtk.scm \ guix/build-system/gnu.scm \ + guix/build-system/gnu2.scm \ guix/build-system/guile.scm \ guix/build-system/haskell.scm \ guix/build-system/julia.scm \ @@ -217,6 +218,7 @@ MODULES = \ guix/build/glib-or-gtk-build-system.scm \ guix/build/gnu-bootstrap.scm \ guix/build/gnu-build-system.scm \ + guix/build/gnu-build-system2.scm \ guix/build/gnu-dist.scm \ guix/build/guile-build-system.scm \ guix/build/maven-build-system.scm \ diff --git a/guix/build-system/gnu2.scm b/guix/build-system/gnu2.scm new file mode 100644 index 0000000000..95fce76714 --- /dev/null +++ b/guix/build-system/gnu2.scm @@ -0,0 +1,580 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012-2022 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix build-system gnu2) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix memoization) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix packages) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:export (%gnu-build-system-modules2 + gnu-build2 + gnu-build-system2 + standard-packages2 + standard-cross-packages2 + package-with-explicit-inputs2 + package-with-extra-configure-variable2 + static-libgcc-package2 + static-package2 + dist-package2 + package-with-restricted-references2)) + +;; Commentary: +;; +;; Standard build procedure for packages using the GNU Build System or +;; something compatible ("./configure && make && make install"). +;; +;; Code: + +(define %gnu-build-system-modules2 + ;; Build-side modules imported and used by default. + '((guix build gnu-build-system2) + (guix build utils) + (guix build gremlin) + (guix elf))) + +(define %default-modules + ;; Modules in scope in the build-side environment. + '((guix build gnu-build-system2) + (guix build utils))) + +(define* (package-with-explicit-inputs/deprecated p inputs + #:optional + (loc (current-source-location)) + #:key (native-inputs '()) + guile) + "This variant is deprecated because it is inefficient: it memoizes only +temporarily instead of memoizing across all transformations where INPUTS is +the same. + +Rewrite P, which is assumed to use GNU-BUILD-SYSTEM2, to take INPUTS and +NATIVE-INPUTS as explicit inputs instead of the implicit default, and return +it. INPUTS and NATIVE-INPUTS can be either input lists or thunks; in the +latter case, they will be called in a context where the `%current-system' and +`%current-target-system' are suitably parametrized. Use GUILE to run the +builder, or the distro's final Guile when GUILE is #f." + (define inputs* inputs) + (define native-inputs* native-inputs) + + (define (call inputs) + (if (procedure? inputs) + (inputs) + inputs)) + + (define (duplicate-filter inputs) + (let ((names (match (call inputs) + (((name _ ...) ...) + name)))) + (lambda (inputs) + (fold alist-delete inputs names)))) + + (let loop ((p p)) + (define rewritten-input + (mlambda (input) + (match input + ((name (? package? p) sub-drv ...) + ;; XXX: Check whether P's build system knows #:implicit-inputs, for + ;; things like `cross-pkg-config'. + (if (eq? (package-build-system p) gnu-build-system2) + (cons* name (loop p) sub-drv) + (cons* name p sub-drv))) + (x x)))) + + (package (inherit p) + (location (if (pair? loc) (source-properties->location loc) loc)) + (arguments + ;; 'ensure-keyword-arguments' guarantees that this procedure is + ;; idempotent. + (ensure-keyword-arguments (package-arguments p) + `(#:guile ,guile + #:implicit-inputs? #f))) + (replacement + (let ((replacement (package-replacement p))) + (and replacement + (package-with-explicit-inputs2 replacement inputs loc + #:native-inputs + native-inputs + #:guile guile)))) + (native-inputs + (let ((filtered (duplicate-filter native-inputs*))) + `(,@(call native-inputs*) + ,@(map rewritten-input + (filtered (package-native-inputs p)))))) + (propagated-inputs + (map rewritten-input + (package-propagated-inputs p))) + (inputs + (let ((filtered (duplicate-filter inputs*))) + `(,@(call inputs*) + ,@(map rewritten-input + (filtered (package-inputs p))))))))) + +(define* (package-with-explicit-inputs* inputs #:optional guile) + "Return a procedure that rewrites the given package and all its dependencies +so that they use INPUTS (a thunk) instead of implicit inputs." + (define (duplicate-filter package-inputs) + (let ((names (match (inputs) + (((name _ ...) ...) + name)))) + (fold alist-delete package-inputs names))) + + (define (add-explicit-inputs p) + (if (and (eq? (package-build-system p) gnu-build-system2) + (not (memq #:implicit-inputs? (package-arguments p)))) + (package + (inherit p) + (inputs (append (inputs) + (duplicate-filter (package-inputs p)))) + (arguments + (ensure-keyword-arguments (package-arguments p) + `(#:implicit-inputs? #f + #:guile ,guile)))) + p)) + + (define (cut? p) + (or (not (eq? (package-build-system p) gnu-build-system2)) + (memq #:implicit-inputs? (package-arguments p)))) + + (package-mapping add-explicit-inputs cut?)) + +(define package-with-explicit-inputs2 + (case-lambda* + ((inputs #:optional guile) + (package-with-explicit-inputs* inputs guile)) + ((p inputs #:optional (loc (current-source-location)) + #:key (native-inputs '()) guile) + ;; deprecated + (package-with-explicit-inputs/deprecated p inputs + loc + #:native-inputs + native-inputs + #:guile guile)))) + +(define (package-with-extra-configure-variable2 p variable value) + "Return a version of P with VARIABLE=VALUE specified as an extra `configure' +flag, recursively. An example is LDFLAGS=-static. If P already has configure +flags for VARIABLE, the associated value is augmented." + (let loop ((p p)) + (define (rewritten-inputs inputs) + (map (match-lambda + ((name (? package? p) sub ...) + `(,name ,(loop p) ,@sub)) + (input input)) + inputs)) + + (package (inherit p) + (arguments + (let ((args (package-arguments p))) + (substitute-keyword-arguments args + ((#:configure-flags flags) + (let* ((var= (string-append variable "=")) + (len (string-length var=))) + `(cons ,(string-append var= value) + (map (lambda (flag) + (if (string-prefix? ,var= flag) + (string-append + ,(string-append var= value " ") + (substring flag ,len)) + flag)) + ,flags))))))) + (replacement + (let ((replacement (package-replacement p))) + (and replacement + (package-with-extra-configure-variable2 replacement + variable value)))) + (inputs (rewritten-inputs (package-inputs p))) + (propagated-inputs (rewritten-inputs (package-propagated-inputs p)))))) + +(define (static-libgcc-package2 p) + "A version of P linked with `-static-gcc'." + (package-with-extra-configure-variable2 p "LDFLAGS" "-static-libgcc")) + +(define* (static-package2 p #:key (strip-all? #t)) + "Return a statically-linked version of package P. If STRIP-ALL? is true, +use `--strip-all' as the arguments to `strip'." + (package (inherit p) + (arguments + (let ((a (default-keyword-arguments (package-arguments p) + '(#:configure-flags '() + #:strip-flags '("--strip-unneeded"))))) + (substitute-keyword-arguments a + ((#:configure-flags flags) + `(cons* "--disable-shared" "LDFLAGS=-static" ,flags)) + ((#:strip-flags flags) + (if strip-all? + ''("--strip-all") + flags))))) + (replacement (and=> (package-replacement p) static-package2)))) + +(define* (dist-package2 p source #:key (phases '%dist-phases)) + "Return a package that takes source files from the SOURCE directory, +runs `make distcheck' and whose result is one or more source tarballs. The +exact build phases are defined by PHASES." + (let ((s source)) + (package (inherit p) + (name (string-append (package-name p) "-dist")) + (source s) + (arguments + ;; Use the right phases and modules. + (substitute-keyword-arguments (package-arguments p) + ((#:modules modules %default-modules) + `((guix build gnu-dist) + ,@modules)) + ((#:imported-modules modules %gnu-build-system-modules2) + `((guix build gnu-dist) + ,@modules)) + ((#:phases _ #f) + phases))) + (native-inputs + ;; Add autotools & co. as inputs. + (let ((ref (lambda (module var) + (module-ref (resolve-interface module) var)))) + `(,@(package-native-inputs p) + ("autoconf" ,(ref '(gnu packages autotools) 'autoconf-wrapper)) + ("automake" ,(ref '(gnu packages autotools) 'automake)) + ("libtool" ,(ref '(gnu packages autotools) 'libtool)) + ("gettext" ,(ref '(gnu packages gettext) 'gnu-gettext)) + ("texinfo" ,(ref '(gnu packages texinfo) 'texinfo)))))))) + +(define (package-with-restricted-references2 p refs) + "Return a package whose outputs are guaranteed to only refer to the packages +listed in REFS." + (if (eq? (package-build-system p) gnu-build-system2) ; XXX: dirty + (package (inherit p) + (arguments `(#:allowed-references ,refs + ,@(package-arguments p)))) + p)) + + +(define (standard-packages2) + "Return the list of (NAME PACKAGE OUTPUT) or (NAME PACKAGE) tuples of +standard packages used as implicit inputs of the gnu-build-system2." + + ;; Resolve (gnu packages commencement) lazily to hide circular dependency. + (let ((distro (resolve-module '(gnu packages commencement)))) + (module-ref distro '%final-inputs))) + +(define* (lower name + #:key source inputs native-inputs outputs target + (implicit-inputs? #t) (implicit-cross-inputs? #t) + (strip-binaries? #t) system + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME from the given arguments." + (define private-keywords + `(#:inputs #:native-inputs #:outputs + #:implicit-inputs? #:implicit-cross-inputs? + ,@(if target '() '(#:target)))) + + (bag + (name name) + (system system) (target target) + (build-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@native-inputs + + ;; When not cross-compiling, ensure implicit inputs come + ;; last. That way, libc headers come last, which allows + ;; #include_next to work correctly; see + ;; . + ,@(if target '() inputs) + ,@(if (and target implicit-cross-inputs?) + (standard-cross-packages2 target 'host) + '()) + ,@(if implicit-inputs? + (standard-packages2) + '()))) + (host-inputs (if target inputs '())) + + ;; The cross-libc is really a target package, but for bootstrapping + ;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a + ;; native package, so it would end up using a "native" variant of + ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages + ;; would use a target variant (built with 'gnu-cross-build'.) + (target-inputs (if (and target implicit-cross-inputs?) + (standard-cross-packages2 target 'target) + '())) + (outputs (if strip-binaries? + outputs + (delete "debug" outputs))) + (build (if target gnu-cross-build gnu-build2)) + (arguments (strip-keyword-arguments private-keywords arguments)))) + +(define %license-file-regexp + ;; Regexp matching license files. + "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$") + +(define %bootstrap-scripts + ;; Typical names of Autotools "bootstrap" scripts. + #~%bootstrap-scripts) + +(define %strip-flags + #~'("--strip-unneeded" "--enable-deterministic-archives")) + +(define %strip-directories + #~'("lib" "lib64" "libexec" "bin" "sbin")) + +(define* (gnu-build2 name inputs + #:key + guile source + (outputs '("out")) + (search-paths '()) + (bootstrap-scripts %bootstrap-scripts) + (configure-flags ''()) + (make-flags ''()) + (out-of-source? #f) + (tests? #t) + (test-target "check") + (parallel-build? #t) + (parallel-tests? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags %strip-flags) + (strip-directories %strip-directories) + (validate-runpath? #t) + (make-dynamic-linker-cache? #t) + (license-file-regexp %license-file-regexp) + (phases '%standard-phases) + (locale "en_US.utf8") + (system (%current-system)) + (build (nix-system->gnu-triplet system)) + (imported-modules %gnu-build-system-modules2) + (modules %default-modules) + (substitutable? #t) + allowed-references + disallowed-references) + "Return a derivation called NAME that builds from tarball SOURCE, with +input derivation INPUTS, using the usual procedure of the GNU Build +System. The builder is run with GUILE, or with the distro's final Guile +package if GUILE is #f or omitted. + +The builder is run in a context where MODULES are used; IMPORTED-MODULES +specifies modules not provided by Guile itself that must be imported in +the builder's environment, from the host. Note that we distinguish +between both, because for Guile's own modules like (ice-9 foo), we want +to use GUILE's own version of it, rather than import the user's one, +which could lead to gratuitous input divergence. + +SUBSTITUTABLE? determines whether users may be able to use substitutes of the +returned derivations, or whether they should always build it locally. + +ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs +are allowed to refer to." + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + #$(with-build-variables inputs outputs + #~(gnu-build2 #:source #+source + #:system #$system + #:build #$build + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:locale #$locale + #:bootstrap-scripts #$bootstrap-scripts + #:configure-flags #$(if (pair? configure-flags) + (sexp->gexp configure-flags) + configure-flags) + #:make-flags #$(if (pair? make-flags) + (sexp->gexp make-flags) + make-flags) + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:patch-shebangs? #$patch-shebangs? + #:license-file-regexp #$license-file-regexp + #:strip-binaries? #$strip-binaries? + #:validate-runpath? #$validate-runpath? + #:make-dynamic-linker-cache? #$make-dynamic-linker-cache? + #:license-file-regexp #$license-file-regexp + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + ;; Note: Always pass #:graft? #f. Without it, ALLOWED-REFERENCES & + ;; co. would be interpreted as referring to grafted packages. + (gexp->derivation name builder + #:system system + #:target #f + #:graft? #f + #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) + + +;;; +;;; Cross-compilation. +;;; + +(define standard-cross-packages2 + (mlambda (target kind) + "Return the list of name/package tuples to cross-build for TARGET. KIND +is one of `host' or `target'." + (let* ((cross (resolve-interface '(gnu packages cross-base))) + (gcc (module-ref cross 'cross-gcc)) + (binutils (module-ref cross 'cross-binutils)) + (libc (module-ref cross 'cross-libc))) + (case kind + ((host) + ;; Cross-GCC appears once here, so that it's in $PATH... + `(("cross-gcc" ,(gcc target + #:xbinutils (binutils target) + #:libc (libc target))) + ("cross-binutils" ,(binutils target)))) + ((target) + (let ((libc (libc target))) + ;; ... and once here, so that libstdc++ & co. are in + ;; CROSS_CPLUS_INCLUDE_PATH, etc. + `(("cross-gcc" ,(gcc target + #:xbinutils (binutils target) + #:libc libc)) + ("cross-libc" ,libc) + + ;; MinGW's libc doesn't have a "static" output. + ,@(if (member "static" (package-outputs libc)) + `(("cross-libc:static" ,libc "static")) + '())))))))) + +(define* (gnu-cross-build name + #:key + target + build-inputs target-inputs host-inputs + guile source + (outputs '("out")) + (search-paths '()) + (native-search-paths '()) + + (bootstrap-scripts %bootstrap-scripts) + (configure-flags ''()) + (make-flags ''()) + (out-of-source? #f) + (tests? #f) ; nothing can be done + (test-target "check") + (parallel-build? #t) (parallel-tests? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags %strip-flags) + (strip-directories %strip-directories) + (validate-runpath? #t) + + ;; We run 'ldconfig' to generate ld.so.cache and it + ;; generally can't do that for cross-built binaries + ;; ("ldconfig: foo.so is for unknown machine 40."). + (make-dynamic-linker-cache? #f) + + (license-file-regexp %license-file-regexp) + (phases '%standard-phases) + (locale "en_US.utf8") + (system (%current-system)) + (build (nix-system->gnu-triplet system)) + (imported-modules %gnu-build-system-modules2) + (modules %default-modules) + (substitutable? #t) + allowed-references + disallowed-references) + "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are +cross-built inputs, and NATIVE-INPUTS are inputs that run on the build +platform." + (define builder + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) + + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + + (define %build-inputs + (append %build-host-inputs %build-target-inputs)) + + (define %outputs + #$(outputs->gexp outputs)) + + (gnu-build2 #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths '#$(sexp->gexp + (map + search-path-specification->sexp + native-search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:locale #$locale + #:bootstrap-scripts #$bootstrap-scripts + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:patch-shebangs? #$patch-shebangs? + #:license-file-regexp #$license-file-regexp + #:strip-binaries? #$strip-binaries? + #:validate-runpath? #$validate-runpath? + #:make-dynamic-linker-cache? #$make-dynamic-linker-cache? + #:license-file-regexp #$license-file-regexp + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:graft? #f + #:modules imported-modules + #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) + +(define gnu-build-system2 + (build-system + (name 'gnu) + (description + "The GNU Build System—i.e., ./configure && make && make install") + (lower lower))) diff --git a/guix/build/gnu-build-system2.scm b/guix/build/gnu-build-system2.scm new file mode 100644 index 0000000000..54129549c2 --- /dev/null +++ b/guix/build/gnu-build-system2.scm @@ -0,0 +1,937 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2018 Mark H Weaver +;;; Copyright © 2020 Brendan Tildesley +;;; Copyright © 2021 Maxim Cournoyer +;;; +;;; 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 . + +(define-module (guix build gnu-build-system2) + #:use-module (guix build utils) + #:use-module (guix build gremlin) + #:use-module (guix elf) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 format) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-26) + #:use-module (rnrs io ports) + #:export (%standard-phases + %license-file-regexp + %bootstrap-scripts + dump-file-contents + gnu-build2)) + +;; Commentary: +;; +;; Standard build procedure for packages using the GNU Build System or +;; something compatible ("./configure && make && make install"). This is the +;; builder-side code. +;; +;; Code: + +(cond-expand + (guile-2.2 + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. + (define time-monotonic time-tai)) + (else #t)) + +(define* (set-SOURCE-DATE-EPOCH #:rest _) + "Set the 'SOURCE_DATE_EPOCH' environment variable. This is used by tools +that incorporate timestamps as a way to tell them to use a fixed timestamp. +See https://reproducible-builds.org/specs/source-date-epoch/." + (setenv "SOURCE_DATE_EPOCH" "1")) + +(define (first-subdirectory directory) + "Return the file name of the first sub-directory of DIRECTORY or false, when +there are none." + (match (scandir directory + (lambda (file) + (and (not (member file '("." ".."))) + (file-is-directory? (string-append directory "/" + file))))) + ((first . _) first) + (_ #f))) + +(define* (set-paths #:key target inputs native-inputs + (search-paths '()) (native-search-paths '()) + #:allow-other-keys) + (define input-directories + ;; The "source" input can be a directory, but we don't want it for search + ;; paths. See . + (match (alist-delete "source" inputs) + (((_ . dir) ...) + dir))) + + (define native-input-directories + (match native-inputs + (((_ . dir) ...) + dir) + (#f ; not cross compiling + '()))) + + ;; Tell 'ld-wrapper' to disallow non-store libraries. + (setenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES" "no") + + ;; When cross building, $PATH must refer only to native (host) inputs since + ;; target inputs are not executable. + (set-path-environment-variable "PATH" '("bin" "sbin") + (append native-input-directories + (if target + '() + input-directories))) + + (for-each (match-lambda + ((env-var (files ...) separator type pattern) + (set-path-environment-variable env-var files + input-directories + #:separator separator + #:type type + #:pattern pattern))) + search-paths) + + (when native-search-paths + ;; Search paths for native inputs, when cross building. + (for-each (match-lambda + ((env-var (files ...) separator type pattern) + (set-path-environment-variable env-var files + native-input-directories + #:separator separator + #:type type + #:pattern pattern))) + native-search-paths))) + +(define* (install-locale #:key + (locale "en_US.utf8") + (locale-category LC_ALL) + #:allow-other-keys) + "Try to install LOCALE; emit a warning if that fails. The main goal is to +use a UTF-8 locale so that Guile correctly interprets UTF-8 file names. + +This phase must typically happen after 'set-paths' so that $LOCPATH has a +chance to be set." + (catch 'system-error + (lambda () + (setlocale locale-category locale) + + ;; While we're at it, pass it to sub-processes. + (setenv (locale-category->string locale-category) locale) + + (format (current-error-port) "using '~a' locale for category ~s~%" + locale (locale-category->string locale-category))) + (lambda args + ;; This is known to fail for instance in early bootstrap where locales + ;; are not available. + (format (current-error-port) + "warning: failed to install '~a' locale: ~a~%" + locale (strerror (system-error-errno args)))))) + +(define* (unpack #:key source #:allow-other-keys) + "Unpack SOURCE in the working directory, and change directory within the +source. When SOURCE is a directory, copy it in a sub-directory of the current +working directory." + (if (file-is-directory? source) + (begin + (mkdir "source") + (chdir "source") + + ;; Preserve timestamps (set to the Epoch) on the copied tree so that + ;; things work deterministically. + (copy-recursively source "." + #:keep-mtime? #t) + ;; Make the source checkout files writable, for convenience. + (for-each (lambda (f) + (false-if-exception (make-file-writable f))) + (find-files "."))) + (begin + (cond + ((string-suffix? ".zip" source) + (invoke "unzip" source)) + ((tarball? source) + (invoke "tar" "xvf" source)) + (else + (let ((name (strip-store-file-name source)) + (command (compressor source))) + (copy-file source name) + (when command + (invoke command "--decompress" name))))) + ;; Attempt to change into child directory. + (and=> (first-subdirectory ".") chdir)))) + +(define %bootstrap-scripts + ;; Typical names of Autotools "bootstrap" scripts. + '("bootstrap" "bootstrap.sh" "autogen.sh")) + +(define* (bootstrap #:key (bootstrap-scripts %bootstrap-scripts) + #:allow-other-keys) + "If the code uses Autotools and \"configure\" is missing, run +\"autoreconf\". Otherwise do nothing." + ;; Note: Run that right after 'unpack' so that the generated files are + ;; visible when the 'patch-source-shebangs' phase runs. + (define (script-exists? file) + (and (file-exists? file) + (not (file-is-directory? file)))) + + (if (not (script-exists? "configure")) + + ;; First try one of the BOOTSTRAP-SCRIPTS. If none exists, and it's + ;; clearly an Autoconf-based project, run 'autoreconf'. Otherwise, do + ;; nothing (perhaps the user removed or overrode the 'configure' phase.) + (let ((script (find script-exists? bootstrap-scripts))) + ;; GNU packages often invoke the 'git-version-gen' script from + ;; 'configure.ac' so make sure it has a valid shebang. + (false-if-file-not-found + (patch-shebang "build-aux/git-version-gen")) + + (if script + (let ((script (string-append "./" script))) + (setenv "NOCONFIGURE" "true") + (format #t "running '~a'~%" script) + (if (executable-file? script) + (begin + (patch-shebang script) + (invoke script)) + (invoke "sh" script)) + ;; Let's clean up after ourselves. + (unsetenv "NOCONFIGURE")) + (if (or (file-exists? "configure.ac") + (file-exists? "configure.in")) + (invoke "autoreconf" "-vif") + (format #t "no 'configure.ac' or anything like that, \ +doing nothing~%")))) + (format #t "GNU build system bootstrapping not needed~%"))) + +;; See . +(define* (patch-usr-bin-file #:key native-inputs inputs + (patch-/usr/bin/file? #t) + #:allow-other-keys) + "Patch occurrences of \"/usr/bin/file\" in all the executable 'configure' +files found in the source tree. This works around Libtool's Autoconf macros, +which generates invocations of \"/usr/bin/file\" that are used to determine +things like the ABI being used." + (when patch-/usr/bin/file? + (for-each (lambda (file) + (when (executable-file? file) + (patch-/usr/bin/file file))) + (find-files "." "^configure$")))) + +(define* (patch-source-shebangs #:key source #:allow-other-keys) + "Patch shebangs in all source files; this includes non-executable +files such as `.in' templates. Most scripts honor $SHELL and +$CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's +`missing' script." + (for-each patch-shebang + (find-files "." + (lambda (file stat) + ;; Filter out symlinks. + (eq? 'regular (stat:type stat))) + #:stat lstat))) + +(define (patch-generated-file-shebangs . rest) + "Patch shebangs in generated files, including `SHELL' variables in +makefiles." + ;; Patch executable regular files, some of which might have been generated + ;; by `configure'. + (for-each patch-shebang + (find-files "." + (lambda (file stat) + (and (eq? 'regular (stat:type stat)) + (not (zero? (logand (stat:mode stat) #o100))))) + #:stat lstat)) + + ;; Patch `SHELL' in generated makefiles. + (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))) + +(define* (configure #:key build target native-inputs inputs outputs + (configure-flags '()) out-of-source? + #:allow-other-keys) + (define (package-name) + (let* ((out (assoc-ref outputs "out")) + (base (basename out)) + (dash (string-rindex base #\-))) + ;; XXX: We'd rather use `package-name->name+version' or similar. + (string-drop (if dash + (substring base 0 dash) + base) + (+ 1 (string-index base #\-))))) + + (let* ((prefix (assoc-ref outputs "out")) + (bindir (assoc-ref outputs "bin")) + (libdir (assoc-ref outputs "lib")) + (includedir (assoc-ref outputs "include")) + (docdir (assoc-ref outputs "doc")) + (bash (or (and=> (assoc-ref (or native-inputs inputs) "bash") + (cut string-append <> "/bin/bash")) + "/bin/sh")) + (flags `(,@(if target ; cross building + '("CC_FOR_BUILD=gcc") + '()) + ,(string-append "CONFIG_SHELL=" bash) + ,(string-append "SHELL=" bash) + ,(string-append "--prefix=" prefix) + "--enable-fast-install" ; when using Libtool + + ;; Produce multiple outputs when specific output names + ;; are recognized. + ,@(if bindir + (list (string-append "--bindir=" bindir "/bin")) + '()) + ,@(if libdir + (cons (string-append "--libdir=" libdir "/lib") + (if includedir + '() + (list + (string-append "--includedir=" + libdir "/include")))) + '()) + ,@(if includedir + (list (string-append "--includedir=" + includedir "/include")) + '()) + ,@(if docdir + (list (string-append "--docdir=" docdir + "/share/doc/" (package-name))) + '()) + ,@(if build + (list (string-append "--build=" build)) + '()) + ,@(if target ; cross building + (list (string-append "--host=" target)) + '()) + ,@configure-flags)) + (abs-srcdir (getcwd)) + (srcdir (if out-of-source? + (string-append "../" (basename abs-srcdir)) + "."))) + (format #t "source directory: ~s (relative from build: ~s)~%" + abs-srcdir srcdir) + (if out-of-source? + (begin + (mkdir "../build") + (chdir "../build"))) + (format #t "build directory: ~s~%" (getcwd)) + (format #t "configure flags: ~s~%" flags) + + ;; Use BASH to reduce reliance on /bin/sh since it may not always be + ;; reliable (see + ;; + ;; for a summary of the situation.) + ;; + ;; Call `configure' with a relative path. Otherwise, GCC's build system + ;; (for instance) records absolute source file names, which typically + ;; contain the hash part of the `.drv' file, leading to a reference leak. + (apply invoke bash + (string-append srcdir "/configure") + flags))) + +(define* (build #:key (make-flags '()) (parallel-build? #t) + #:allow-other-keys) + (apply invoke "make" + `(,@(if parallel-build? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags))) + +(define* (dump-file-contents directory file-regexp + #:optional (port (current-error-port))) + "Dump to PORT the contents of files in DIRECTORY that match FILE-REGEXP." + (define (dump file) + (let ((prefix (string-append "\n--- " file " "))) + (display (if (< (string-length prefix) 78) + (string-pad-right prefix 78 #\-) + prefix) + port) + (display "\n\n" port) + (call-with-input-file file + (lambda (log) + (dump-port log port))) + (display "\n" port))) + + (for-each dump (find-files directory file-regexp))) + +(define %test-suite-log-regexp + ;; Name of test suite log files as commonly found in GNU-based build systems + ;; and CMake. + "^(test-?suite\\.log|LastTestFailed\\.log)$") + +(define* (check #:key target (make-flags '()) (tests? (not target)) + (test-target "check") (parallel-tests? #t) + (test-suite-log-regexp %test-suite-log-regexp) + #:allow-other-keys) + (if tests? + (guard (c ((invoke-error? c) + ;; Dump the test suite log to facilitate debugging. + (display "\nTest suite failed, dumping logs.\n" + (current-error-port)) + (dump-file-contents "." test-suite-log-regexp) + (raise c))) + (apply invoke "make" test-target + `(,@(if parallel-tests? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags))) + (format #t "test suite not run~%"))) + +(define* (install #:key (make-flags '()) #:allow-other-keys) + (apply invoke "make" "install" make-flags)) + +(define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t) + #:allow-other-keys) + (define (list-of-files dir) + (map (cut string-append dir "/" <>) + (or (scandir dir (lambda (f) + (let ((s (lstat (string-append dir "/" f)))) + (eq? 'regular (stat:type s))))) + '()))) + + (define bin-directories + (match-lambda + ((_ . dir) + (list (string-append dir "/bin") + (string-append dir "/sbin") + (string-append dir "/libexec"))))) + + (define output-bindirs + (append-map bin-directories outputs)) + + (define input-bindirs + ;; Shebangs should refer to binaries of the target system---i.e., from + ;; "inputs", not from "native-inputs". + (append-map bin-directories inputs)) + + (when patch-shebangs? + (let ((path (append output-bindirs input-bindirs))) + (for-each (lambda (dir) + (let ((files (list-of-files dir))) + (for-each (cut patch-shebang <> path) files))) + output-bindirs)))) + +(define* (strip #:key target outputs (strip-binaries? #t) + (strip-command (if target + (string-append target "-strip") + "strip")) + (objcopy-command (if target + (string-append target "-objcopy") + "objcopy")) + (strip-flags '("--strip-unneeded" + "--enable-deterministic-archives")) + (strip-directories '("lib" "lib64" "libexec" + "bin" "sbin")) + #:allow-other-keys) + (define debug-output + ;; If an output is called "debug", then that's where debugging information + ;; will be stored instead of being discarded. + (assoc-ref outputs "debug")) + + (define debug-file-extension + ;; File name extension for debugging information. + ".debug") + + (define (debug-file file) + ;; Return the name of the debug file for FILE, an absolute file name. + ;; Once installed in the user's profile, it is in $PROFILE/lib/debug/FILE, + ;; which is where GDB looks for it (info "(gdb) Separate Debug Files"). + (string-append debug-output "/lib/debug/" + file debug-file-extension)) + + (define (make-debug-file file) + ;; Create a file in DEBUG-OUTPUT containing the debugging info of FILE. + (let ((debug (debug-file file))) + (mkdir-p (dirname debug)) + (copy-file file debug) + (invoke strip-command "--only-keep-debug" debug) + (chmod debug #o400))) + + (define (add-debug-link file) + ;; Add a debug link in FILE (info "(binutils) strip"). + + ;; `objcopy --add-gnu-debuglink' wants to have the target of the debug + ;; link around so it can compute a CRC of that file (see the + ;; `bfd_fill_in_gnu_debuglink_section' function.) No reference to + ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug + ;; file. + (invoke objcopy-command "--enable-deterministic-archives" + (string-append "--add-gnu-debuglink=" + (debug-file file)) + file)) + + (define (strip-dir dir) + (format #t "stripping binaries in ~s with ~s and flags ~s~%" + dir strip-command strip-flags) + (when debug-output + (format #t "debugging output written to ~s using ~s~%" + debug-output objcopy-command)) + + (for-each (lambda (file) + (when (or (elf-file? file) (ar-file? file)) + ;; If an error occurs while processing a file, issue a + ;; warning and continue to the next file. + (guard (c ((invoke-error? c) + (format (current-error-port) + "warning: ~a: program ~s exited\ +~@[ with non-zero exit status ~a~]\ +~@[ terminated by signal ~a~]~%" + file + (invoke-error-program c) + (invoke-error-exit-status c) + (invoke-error-term-signal c)))) + (when debug-output + (make-debug-file file)) + + ;; Ensure the file is writable. + (make-file-writable file) + + (apply invoke strip-command + (append strip-flags (list file))) + + (when debug-output + (add-debug-link file))))) + (find-files dir + (lambda (file stat) + ;; Ignore symlinks such as: + ;; libfoo.so -> libfoo.so.0.0. + (eq? 'regular (stat:type stat))) + #:stat lstat))) + + (when strip-binaries? + (for-each + strip-dir + (append-map (match-lambda + ((_ . dir) + (filter-map (lambda (d) + (let ((sub (string-append dir "/" d))) + (and (directory-exists? sub) sub))) + strip-directories))) + outputs)))) + +(define* (validate-runpath #:key + (validate-runpath? #t) + (elf-directories '("lib" "lib64" "libexec" + "bin" "sbin")) + outputs #:allow-other-keys) + "When VALIDATE-RUNPATH? is true, validate that all the ELF files in +ELF-DIRECTORIES have their dependencies found in their 'RUNPATH'. + +Since the ELF parser needs to have a copy of files in memory, better run this +phase after stripping." + (define (sub-directory parent) + (lambda (directory) + (let ((directory (string-append parent "/" directory))) + (and (directory-exists? directory) directory)))) + + (define (validate directory) + (define (file=? file1 file2) + (let ((st1 (stat file1)) + (st2 (stat file2))) + (= (stat:ino st1) (stat:ino st2)))) + + ;; There are always symlinks from '.so' to '.so.1' and so on, so delete + ;; duplicates. + (let ((files (delete-duplicates (find-files directory (lambda (file stat) + (elf-file? file))) + file=?))) + (format (current-error-port) + "validating RUNPATH of ~a binaries in ~s...~%" + (length files) directory) + (every* validate-needed-in-runpath files))) + + (if validate-runpath? + (let ((dirs (append-map (match-lambda + (("debug" . _) + ;; The "debug" output is full of ELF files + ;; that are not worth checking. + '()) + ((name . output) + (filter-map (sub-directory output) + elf-directories))) + outputs))) + (unless (every* validate dirs) + (error "RUNPATH validation failed"))) + (format (current-error-port) "skipping RUNPATH validation~%"))) + +(define* (validate-documentation-location #:key outputs + #:allow-other-keys) + "Documentation should go to 'share/info' and 'share/man', not just 'info/' +and 'man/'. This phase moves directories to the right place if needed." + (define (validate-sub-directory output sub-directory) + (let ((directory (string-append output "/" sub-directory))) + (when (directory-exists? directory) + (let ((target (string-append output "/share/" sub-directory))) + (format #t "moving '~a' to '~a'~%" directory target) + (mkdir-p (dirname target)) + (rename-file directory target))))) + + (define (validate-output output) + (for-each (cut validate-sub-directory output <>) + '("man" "info"))) + + (match outputs + (((names . directories) ...) + (for-each validate-output directories)))) + +(define* (reset-gzip-timestamps #:key outputs #:allow-other-keys) + "Reset embedded timestamps in gzip files found in OUTPUTS." + (define (process-directory directory) + (let ((files (find-files directory + (lambda (file stat) + (and (eq? 'regular (stat:type stat)) + (or (string-suffix? ".gz" file) + (string-suffix? ".tgz" file)) + (gzip-file? file))) + #:stat lstat))) + ;; Ensure the files are writable. + (for-each make-file-writable files) + (for-each reset-gzip-timestamp files))) + + (match outputs + (((names . directories) ...) + (for-each process-directory directories)))) + +(define* (compress-documentation #:key outputs + (compress-documentation? #t) + (documentation-compressor "gzip") + (documentation-compressor-flags + '("--best" "--no-name")) + (compressed-documentation-extension ".gz") + #:allow-other-keys) + "When COMPRESS-DOCUMENTATION? is true, compress man pages and Info files +found in OUTPUTS using DOCUMENTATION-COMPRESSOR, called with +DOCUMENTATION-COMPRESSOR-FLAGS." + (define (retarget-symlink link) + (let ((target (readlink link))) + (delete-file link) + (symlink (string-append target compressed-documentation-extension) + (string-append link compressed-documentation-extension)))) + + (define (has-links? file) + ;; Return #t if FILE has hard links. + (> (stat:nlink (lstat file)) 1)) + + (define (points-to-symlink? symlink) + ;; Return #t if SYMLINK points to another symbolic link. + (let* ((target (readlink symlink)) + (target-absolute (if (string-prefix? "/" target) + target + (string-append (dirname symlink) + "/" target)))) + (catch 'system-error + (lambda () + (symbolic-link? target-absolute)) + (lambda args + (if (= ENOENT (system-error-errno args)) + (begin + (format (current-error-port) + "The symbolic link '~a' target is missing: '~a'\n" + symlink target-absolute) + #f) + (apply throw args)))))) + + (define (maybe-compress-directory directory regexp) + (when (directory-exists? directory) + (match (find-files directory regexp) + (() ;nothing to compress + #t) + ((files ...) ;one or more files + (format #t + "compressing documentation in '~a' with ~s and flags ~s~%" + directory documentation-compressor + documentation-compressor-flags) + (call-with-values + (lambda () + (partition symbolic-link? files)) + (lambda (symlinks regular-files) + ;; Compress the non-symlink files, and adjust symlinks to refer + ;; to the compressed files. Leave files that have hard links + ;; unchanged ('gzip' would refuse to compress them anyway.) + ;; Also, do not retarget symbolic links pointing to other + ;; symbolic links, since these are not compressed. + (for-each retarget-symlink + (filter (lambda (symlink) + (and (not (points-to-symlink? symlink)) + (string-match regexp symlink))) + symlinks)) + (apply invoke documentation-compressor + (append documentation-compressor-flags + (remove has-links? regular-files))))))))) + + (define (maybe-compress output) + (maybe-compress-directory (string-append output "/share/man") + "\\.[0-9]+$") + (maybe-compress-directory (string-append output "/share/info") + "\\.info(-[0-9]+)?$")) + + (if compress-documentation? + (match outputs + (((names . directories) ...) + (for-each maybe-compress directories))) + (format #t "not compressing documentation~%"))) + +(define* (delete-info-dir-file #:key outputs #:allow-other-keys) + "Delete any 'share/info/dir' file from OUTPUTS." + (for-each (match-lambda + ((output . directory) + (let ((info-dir-file (string-append directory "/share/info/dir"))) + (when (file-exists? info-dir-file) + (delete-file info-dir-file))))) + outputs)) + + +(define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys) + "Replace any references to executables in '.desktop' files with their +absolute file names." + (define bin-directories + (append-map (match-lambda + ((_ . directory) + (list (string-append directory "/bin") + (string-append directory "/sbin")))) + outputs)) + + (define (which program) + (or (search-path bin-directories program) + (begin + (format (current-error-port) + "warning: '.desktop' file refers to '~a', \ +which cannot be found~%" + program) + program))) + + (for-each (match-lambda + ((_ . directory) + (let ((applications (string-append directory + "/share/applications"))) + (when (directory-exists? applications) + (let ((files (find-files applications "\\.desktop$"))) + (format #t "adjusting ~a '.desktop' files in ~s~%" + (length files) applications) + + ;; '.desktop' files contain translations and are always + ;; UTF-8-encoded. + (with-fluids ((%default-port-encoding "UTF-8")) + (substitute* files + (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest) + (string-append "Exec=" (which binary) rest)) + (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest) + (string-append "TryExec=" + (which binary) rest))))))))) + outputs)) + +(define* (make-dynamic-linker-cache #:key outputs + (make-dynamic-linker-cache? #t) + #:allow-other-keys) + "Create a dynamic linker cache under 'etc/ld.so.cache' in each of the +OUTPUTS. This reduces application startup time by avoiding the 'stat' storm +that traversing all the RUNPATH entries entails." + (define (make-cache-for-output directory) + (define bin-directories + (filter-map (lambda (sub-directory) + (let ((directory (string-append directory "/" + sub-directory))) + (and (directory-exists? directory) + directory))) + '("bin" "sbin" "libexec"))) + + (define programs + ;; Programs that can benefit from the ld.so cache. + (append-map (lambda (directory) + (if (directory-exists? directory) + (find-files directory + (lambda (file stat) + (and (executable-file? file) + (elf-file? file)))) + '())) + bin-directories)) + + (define library-path + ;; Directories containing libraries that PROGRAMS depend on, + ;; recursively. + (delete-duplicates + (append-map (lambda (program) + (map dirname (file-needed/recursive program))) + programs))) + + (define cache-file + (string-append directory "/etc/ld.so.cache")) + + (define ld.so.conf + (string-append (or (getenv "TMPDIR") "/tmp") + "/ld.so.conf")) + + (unless (null? library-path) + (mkdir-p (dirname cache-file)) + (guard (c ((invoke-error? c) + ;; Do not treat 'ldconfig' failure as an error. + (format (current-error-port) + "warning: 'ldconfig' failed:~%") + (report-invoke-error c (current-error-port)))) + ;; Create a config file to tell 'ldconfig' where to look for the + ;; libraries that PROGRAMS need. + (call-with-output-file ld.so.conf + (lambda (port) + (for-each (lambda (directory) + (display directory port) + (newline port)) + library-path))) + + (invoke "ldconfig" "-f" ld.so.conf "-C" cache-file) + (format #t "created '~a' from ~a library search path entries~%" + cache-file (length library-path))))) + + (if make-dynamic-linker-cache? + (match outputs + (((_ . directories) ...) + (for-each make-cache-for-output directories))) + (format #t "ld.so cache not built~%"))) + +(define %license-file-regexp + ;; Regexp matching license files. + "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$") + +(define* (install-license-files #:key outputs + (license-file-regexp %license-file-regexp) + out-of-source? + #:allow-other-keys) + "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'." + (define (find-source-directory package) + ;; For an out-of-source build, guess the source directory location + ;; relative to the current directory. Return #f on failure. + (match (scandir ".." + (lambda (file) + (and (not (member file '("." ".." "build"))) + (file-is-directory? + (string-append "../" file))))) + (() ;hmm, no source + #f) + ((source) ;only one other file + (string-append "../" source)) + ((directories ...) ;pick the most likely one + ;; This happens for example with libstdc++, which lives within the GCC + ;; source tree. + (any (lambda (directory) + (and (string-prefix? package directory) + (string-append "../" directory))) + directories)))) + + (define (copy-to-directories directories sub-directory) + (lambda (file) + (for-each (if (file-is-directory? file) + (cut copy-recursively file <>) + (cut install-file file <>)) + (map (cut string-append <> "/" sub-directory) + directories)))) + + (let* ((regexp (make-regexp license-file-regexp)) + (out (or (assoc-ref outputs "out") + (match outputs + (((_ . output) _ ...) + output)))) + (package (strip-store-file-name out)) + (outputs (match outputs + (((_ . outputs) ...) + outputs))) + (source (if out-of-source? + (find-source-directory + (package-name->name+version package)) + ".")) + (files (and source + (scandir source + (lambda (file) + (regexp-exec regexp file)))))) + (if files + (begin + (format #t "installing ~a license files from '~a'~%" + (length files) source) + (for-each (copy-to-directories outputs + (string-append "share/doc/" + package)) + (map (cut string-append source "/" <>) files))) + (format (current-error-port) + "failed to find license files~%")))) + +(define %standard-phases + ;; Standard build phases, as a list of symbol/procedure pairs. + (let-syntax ((phases (syntax-rules () + ((_ p ...) `((p . ,p) ...))))) + (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack + bootstrap + patch-usr-bin-file + patch-source-shebangs configure patch-generated-file-shebangs + build check install + patch-shebangs strip + validate-runpath + validate-documentation-location + delete-info-dir-file + patch-dot-desktop-files + make-dynamic-linker-cache + install-license-files + reset-gzip-timestamps + compress-documentation))) + + +(define* (gnu-build2 #:key (source #f) (outputs #f) (inputs #f) + (phases %standard-phases) + #:allow-other-keys + #:rest args) + "Build from SOURCE to OUTPUTS, using INPUTS, and by running all of PHASES +in order. Return #t if all the PHASES succeeded, #f otherwise." + (define (elapsed-time end start) + (let ((diff (time-difference end start))) + (+ (time-second diff) + (/ (time-nanosecond diff) 1e9)))) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + ;; Encoding/decoding errors shouldn't be silent. + (fluid-set! %default-port-conversion-strategy 'error) + + (guard (c ((invoke-error? c) + (report-invoke-error c) + (exit 1))) + ;; The trick is to #:allow-other-keys everywhere, so that each procedure in + ;; PHASES can pick the keyword arguments it's interested in. + (for-each (match-lambda + ((name . proc) + (let ((start (current-time time-monotonic))) + (define (end-of-phase success?) + (let ((end (current-time time-monotonic))) + (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" + name success? + (elapsed-time end start)) + + ;; Dump the environment variables as a shell script, + ;; for handy debugging. + (system "export > $NIX_BUILD_TOP/environment-variables"))) + + (format #t "starting phase `~a'~%" name) + (with-throw-handler #t + (lambda () + (apply proc args) + (end-of-phase #t)) + (lambda args + ;; This handler executes before the stack is unwound. + ;; The exception is automatically re-thrown from here, + ;; and we should get a proper backtrace. + (format (current-error-port) + "error: in phase '~a': uncaught exception: +~{~s ~}~%" name args) + (end-of-phase #f)))))) + phases))) base-commit: e2bcd41ce35b051f311e36dfd104d36ce1145f8b prerequisite-patch-id: 77c51f63cfaba6cafe4e7125f50077d6dc5ca24a prerequisite-patch-id: 776778c03bce9b7ad3ab94a120f42b764c00fcae prerequisite-patch-id: 4910d08bdc27384d76030b6ac491ad2c2ed0957f prerequisite-patch-id: 2de8762a6381a93682d0fe4c893962b9803362b0 prerequisite-patch-id: b9b6f21a2db3f7a5ef82bb11ed23f69749cc6b3d -- 2.38.1