build: Enable cross-compilation for pyproject-build-system.issue-60847

* guix/build-system/pyproject.scm (lower): Do not return #f when TARGET is
set.  Add the target field.  Separate build-inputs from target-inputs, and
extend these with the standard-packages or standard-cross-packages procedures.
(pyproject-build): Add the target, build-inputs, target-inputs, host-inputs
and native-search-paths arguments.  Remove the inputs argument.  Adjust doc.
Adjust the call to the build-side pyproject-build procedure.  Always pass the
target to the gexp->derivation call.
* guix/packages.scm (bag->derivation): Special case the pyproject-build
builder to always use cross-derivation bags
* guix/build/pyproject-build-system.scm (set-paths): New procedure, overriding
that provided by gnu-build-system.
(check) [TARGET]: New argument.  Disable the phase when it is set.
(install): Adjust to look for Python in the native-inputs instead of inputs.
(compile-bytecode): Likewise.
(create-entrypoints): Likewise.
(set-setuptools-env): New procedure.
(sanity-check): Adjust to look for Python in the native-inputs instead of
inputs.
(add-install-to-pythonpath, wrap, rename-pth-file): Likewise.
(%standard-phases): Override set-paths, add-install-to-pythonpath, wrap,
sanity-check and rename-pth-file.  Register set-setuptools-env.

3 files changed, 210 insertions, 77 deletions

diff --git a/guix/build-system/pyproject.scm b/guix/build-system/pyproject.scm
index 8f3b562ca3..74d739023f 100644
--- a/guix/build-system/pyproject.scm
+++ b/guix/build-system/pyproject.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net>
 ;;; Copyright © 2022 Marius Bakke <marius@gnu.org>
+;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -69,28 +70,37 @@
                 #:rest arguments)
   "Return a bag for NAME."
   (define private-keywords
-    '(#:target #:python #:inputs #:native-inputs))
-
-  (and (not target)                               ;XXX: no cross-compilation
-       (bag
-         (name name)
-         (system system)
-         (host-inputs `(,@(if source
-                              `(("source" ,source))
-                              '())
-                        ,@inputs
-
-                        ;; Keep the standard inputs of 'gnu-build-system'.
-                        ,@(standard-packages)))
-         (build-inputs `(("python" ,python)
-                         ("sanity-check.py" ,(local-file sanity-check.py))
-                         ,@native-inputs))
-         (outputs (append outputs '(wheel)))
-         (build pyproject-build)
-         (arguments (strip-keyword-arguments private-keywords arguments)))))
-
-(define* (pyproject-build name inputs
-                          #:key source
+    `(#:python #:inputs #:native-inputs
+      ,@(if target '() '(#:target))))
+
+  (bag
+    (name name)
+    (system system)
+    (target target)
+    (build-inputs `(,@(if source
+                          `(("source" ,source))
+                          '())
+                    ("python" ,python)
+                    ("sanity-check.py" ,(local-file sanity-check.py))
+                    ,@native-inputs
+                    ,@(if target
+                          (standard-cross-packages target 'host)
+                          '())
+                    ;; Keep the standard inputs of 'gnu-build-system'.
+                    ,@(standard-packages)))
+    (host-inputs inputs)
+    (target-inputs (if target
+                       (standard-cross-packages target 'target)
+                       '()))
+    (outputs (append outputs '(wheel)))
+    (build pyproject-build)
+    (arguments (strip-keyword-arguments private-keywords arguments))))
+
+(define* (pyproject-build name
+                          #:key
+                          target
+                          build-inputs target-inputs host-inputs
+                          source
                           (tests? #t)
                           (configure-flags ''())
                           (build-backend #f)
@@ -98,44 +108,63 @@
                           (test-flags ''())
                           (phases '%standard-phases)
                           (outputs '("out" "wheel"))
+                          (native-search-paths '())
                           (search-paths '())
                           (system (%current-system))
                           (guile #f)
                           (imported-modules %pyproject-build-system-modules)
                           (modules '((guix build pyproject-build-system)
                                      (guix build utils))))
-  "Build SOURCE using PYTHON, and with INPUTS."
+  "Build SOURCE using PYTHON, and with BUILD-INPUTS, HOST-INPUTS and
+TARGET-INPUTS (if available)."
   (define build
     (with-imported-modules imported-modules
       #~(begin
           (use-modules #$@(sexp->gexp modules))
 
-          #$(with-build-variables inputs outputs
-              #~(pyproject-build
-                 #:name #$name
-                 #:source #+source
-                 #:configure-flags #$configure-flags
-                 #:system #$system
-                 #:build-backend #$build-backend
-                 #:test-backend #$test-backend
-                 #:test-flags #$test-flags
-                 #:tests? #$tests?
-                 #:phases #$(if (pair? phases)
-                                (sexp->gexp phases)
-                                phases)
-                 #:outputs %outputs
-                 #:search-paths '#$(sexp->gexp
-                                    (map search-path-specification->sexp
-                                         search-paths))
-                 #:inputs %build-inputs)))))
+          (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))
 
+          (pyproject-build #:name #$name
+                           #:source #+source
+                           #:configure-flags #$configure-flags
+                           #:system #$system
+                           #:target #$target
+                           #:build-backend #$build-backend
+                           #:test-backend #$test-backend
+                           #:test-flags #$test-flags
+                           #:tests? #$tests?
+                           #:phases #$(if (pair? phases)
+                                          (sexp->gexp phases)
+                                          phases)
+                           #:outputs %outputs
+                           #:search-paths
+                           '#$(sexp->gexp
+                               (map search-path-specification->sexp
+                                    search-paths))
+                           #:native-search-paths
+                           '#$(sexp->gexp
+                               (map search-path-specification->sexp
+                                    native-search-paths))
+                           #:native-inputs %build-host-inputs
+                           #:inputs %build-target-inputs))))
 
   (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
                                                   system #:graft? #f)))
     (gexp->derivation name build
                       #:system system
-                      #:graft? #f                 ;consistent with 'gnu-build'
-                      #:target #f
+                      #:target target
+                      #:graft? #f       ;consistent with 'gnu-build'
                       #:guile-for-build guile)))
 
 (define pyproject-build-system
diff --git a/guix/build/pyproject-build-system.scm b/guix/build/pyproject-build-system.scm
index c69ccc9d64..e51b5cfc43 100644
--- a/guix/build/pyproject-build-system.scm
+++ b/guix/build/pyproject-build-system.scm
@@ -86,6 +86,58 @@
 ;; Raised, when no wheel has been built by the build system.
 (define-condition-type &no-wheels-built &python-build-error no-wheels-built?)
 
+;;; XXX: This is the same as in (guix build gnu-build-system), except adjusted
+;;; for the fact that native-inputs always exist now, whether cross-compiling
+;;; or not.  When not cross-compiling, input-directories are appended to
+;;; native-input-directories to so that native-search-paths are computed for
+;;; all inputs.
+(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 <https://issues.guix.gnu.org/44924>.
+    (match (alist-delete "source" inputs)
+      (((_ . dir) ...)
+       dir)))
+
+  (define native-input-directories
+    (match (alist-delete "source" native-inputs)
+      (((_ . dir) ...)
+       dir)))
+
+  ;; 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)
+
+  (for-each (match-lambda
+              ((env-var (files ...) separator type pattern)
+               (set-path-environment-variable env-var files
+                                              (append native-input-directories
+                                                      (if target
+                                                          '()
+                                                          input-directories))
+                                              #:separator separator
+                                              #:type type
+                                              #:pattern pattern)))
+            native-search-paths))
+
 (define* (build #:key outputs build-backend configure-flags #:allow-other-keys)
   "Build a given Python package."
 
@@ -135,9 +187,9 @@ builder.build_wheel(sys.argv[2], config_settings=config_settings)"
      wheel-dir
      config-settings)))
 
-(define* (check #:key tests? test-backend test-flags #:allow-other-keys)
+(define* (check #:key target tests? test-backend test-flags #:allow-other-keys)
   "Run the test suite of a given Python package."
-  (if tests?
+  (if (and tests? (not target))
       ;; Unfortunately with PEP 517 there is no common method to specify test
       ;; systems.  Guess test system based on inputs instead.
       (let* ((pytest (which "pytest"))
@@ -172,11 +224,11 @@ builder.build_wheel(sys.argv[2], config_settings=config_settings)"
           (else (raise (condition (&test-system-not-found))))))
       (format #t "test suite not run~%")))
 
-(define* (install #:key inputs outputs #:allow-other-keys)
+(define* (install #:key native-inputs outputs #:allow-other-keys)
   "Install a wheel file according to PEP 427"
   ;; See https://www.python.org/dev/peps/pep-0427/#installing-a-wheel-distribution-1-0-py32-none-any-whl
-  (let ((site-dir (site-packages inputs outputs))
-        (python (assoc-ref inputs "python"))
+  (let ((site-dir (site-packages native-inputs outputs))
+        (python (assoc-ref native-inputs "python"))
         (out (assoc-ref outputs "out")))
     (define (extract file)
       "Extract wheel (ZIP file) into site-packages directory"
@@ -262,10 +314,10 @@ builder.build_wheel(sys.argv[2], config_settings=config_settings)"
                   (expand-data-directory directory)
                   (rmdir directory)) datadirs))))
 
-(define* (compile-bytecode #:key inputs outputs #:allow-other-keys)
+(define* (compile-bytecode #:key native-inputs outputs #:allow-other-keys)
   "Compile installed byte-code in site-packages."
-  (let* ((site-dir (site-packages inputs outputs))
-         (python (assoc-ref inputs "python"))
+  (let* ((site-dir (site-packages native-inputs outputs))
+         (python (assoc-ref native-inputs "python"))
          (major-minor (map string->number
                            (take (string-split (python-version python) #\.) 2)))
          (<3.7? (match major-minor
@@ -281,7 +333,7 @@ builder.build_wheel(sys.argv[2], config_settings=config_settings)"
         (invoke "python" "-m" "compileall"
                 "--invalidation-mode=unchecked-hash" site-dir))))
 
-(define* (create-entrypoints #:key inputs outputs #:allow-other-keys)
+(define* (create-entrypoints #:key native-inputs outputs #:allow-other-keys)
   "Implement Entry Points Specification
 (https://packaging.python.org/specifications/entry-points/) by PyPa,
 which creates runnable scripts in bin/ from entry point specification
@@ -337,8 +389,7 @@ import sys
 import ~a as mod
 sys.exit (mod.~a ())~%" interpreter module function)))
         (chmod file-path #o755)))
-
-  (let* ((site-dir (site-packages inputs outputs))
+  (let* ((site-dir (site-packages native-inputs outputs))
          (out (assoc-ref outputs "out"))
          (bin-dir (string-append out "/bin"))
          (entry-point-files (find-files site-dir "^entry_points.txt$")))
@@ -358,6 +409,51 @@ See https://reproducible-builds.org/specs/source-date-epoch/."
   ;; not support timestamps before 1980.
   (setenv "SOURCE_DATE_EPOCH" "315619200"))
 
+(define* (set-setuptools-env #:key target #:allow-other-keys)
+  "Set environment variables such as LDSHARED, LDXXSHARED, etc. used by
+setuptools when building native extensions.  This is particularly useful for
+cross-compilation."
+  (define cc-for-target (if target
+                            (string-append target "-gcc")
+                            "gcc"))
+  (define cxx-for-target (if target
+                             (string-append target "-g++")
+                             "g++"))
+  ;; The variables defined here are taken from CPython's configure.ac file.
+  ;; The explanations are those of the Poky (from Yocto) project.
+  (setenv "CC" cc-for-target)
+  (setenv "CXX" cxx-for-target)
+  ;; LDSHARED is the ld *command* used to create shared library.
+  (setenv "LDSHARED" (string-append cc-for-target " -shared"))
+  ;; LDXXSHARED is the ld *command* used to create shared library of C++
+  ;; objects.
+  (setenv "LDCXXSHARED" (string-append cxx-for-target " -shared"))
+  ;; CCSHARED are the C *flags* used to create objects to go into a shared
+  ;; library (module).
+  (setenv "CCSHARED" "-fPIC")
+  ;; LINKFORSHARED are the flags passed to the $(CC) command that links the
+  ;; python executable.
+  (setenv "LINKFORSHARED" "-Xlinker -export-dynamic"))
+
+(define* (sanity-check #:key tests? native-inputs outputs #:allow-other-keys
+                       #:rest args)
+  (apply (assoc-ref python:%standard-phases 'sanity-check)
+         (append args (list #:inputs native-inputs))))
+
+(define* (add-install-to-pythonpath #:key native-inputs outputs
+                                    #:allow-other-keys)
+  "A phase that just wraps the 'add-installed-pythonpath' procedure."
+  (add-installed-pythonpath native-inputs outputs))
+
+(define* (wrap #:key native-inputs outputs #:allow-other-keys #:rest args)
+  (apply (assoc-ref python:%standard-phases 'wrap)
+         (append args (list #:inputs native-inputs))))
+
+(define* (rename-pth-file #:key name native-inputs outputs #:allow-other-keys
+                          #:rest args)
+  (apply (assoc-ref python:%standard-phases 'rename-pth-file)
+         (append args (list #:inputs native-inputs))))
+
 (define %standard-phases
   ;; The build phase only builds C extensions and copies the Python sources,
   ;; while the install phase copies then byte-compiles the sources to the
@@ -365,13 +461,19 @@ See https://reproducible-builds.org/specs/source-date-epoch/."
   ;; to ease testing the built package.
   (modify-phases python:%standard-phases
     (replace 'set-SOURCE-DATE-EPOCH set-SOURCE-DATE-EPOCH*)
+    (replace 'set-paths set-paths)
+    (add-after 'set-paths 'set-setuptools-env set-setuptools-env)
     (replace 'build build)
     (replace 'install install)
+    (replace 'add-install-to-pythonpath add-install-to-pythonpath)
+    (replace 'wrap wrap)
     (delete 'check)
     ;; Must be before tests, so they can use installed packages’ entry points.
     (add-before 'wrap 'create-entrypoints create-entrypoints)
     (add-after 'wrap 'check check)
-    (add-before 'check 'compile-bytecode compile-bytecode)))
+    (add-before 'check 'compile-bytecode compile-bytecode)
+    (replace 'sanity-check sanity-check)
+    (replace 'rename-pth-file rename-pth-file)))
 
 (define* (pyproject-build #:key inputs (phases %standard-phases)
                           #:allow-other-keys #:rest args)
diff --git a/guix/packages.scm b/guix/packages.scm
index 041a872f9d..6d7df17fc3 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1864,28 +1864,30 @@ TARGET."
   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
 a package object describing the context in which the call occurs, for improved
 error reporting."
-  (if (bag-target bag)
-      (bag->cross-derivation bag)
-      (mlet* %store-monad ((system ->  (bag-system bag))
-                           (inputs ->  (bag-transitive-inputs bag))
-                           (input-drvs (mapm %store-monad
-                                             (cut expand-input context <> system)
-                                             inputs))
-                           (paths ->   (delete-duplicates
-                                        (append-map (match-lambda
-                                                      ((_ (? package? p) _ ...)
-                                                       (package-native-search-paths
-                                                        p))
-                                                      (_ '()))
-                                                    inputs))))
-        ;; It's possible that INPUTS contains packages that are not 'eq?' but
-        ;; that lead to the same derivation.  Delete those duplicates to avoid
-        ;; issues down the road, such as duplicate entries in '%build-inputs'.
-        (apply (bag-build bag) (bag-name bag)
-               (delete-duplicates input-drvs input=?)
-               #:search-paths paths
-               #:outputs (bag-outputs bag) #:system system
-               (bag-arguments bag)))))
+  (let ((builder-name (procedure-name (bag-build bag))))
+    (if (or (bag-target bag)
+            (eq? 'pyproject-build builder-name))
+        (bag->cross-derivation bag)
+        (mlet* %store-monad ((system ->  (bag-system bag))
+                             (inputs ->  (bag-transitive-inputs bag))
+                             (input-drvs (mapm %store-monad
+                                               (cut expand-input context <> system)
+                                               inputs))
+                             (paths ->   (delete-duplicates
+                                          (append-map (match-lambda
+                                                        ((_ (? package? p) _ ...)
+                                                         (package-native-search-paths
+                                                          p))
+                                                        (_ '()))
+                                                      inputs))))
+          ;; It's possible that INPUTS contains packages that are not 'eq?' but
+          ;; that lead to the same derivation.  Delete those duplicates to avoid
+          ;; issues down the road, such as duplicate entries in '%build-inputs'.
+          (apply (bag-build bag) (bag-name bag)
+                 (delete-duplicates input-drvs input=?)
+                 #:search-paths paths
+                 #:outputs (bag-outputs bag) #:system system
+                 (bag-arguments bag))))))
 
 (define* (bag->cross-derivation bag #:optional context)
   "Return the derivation to build BAG, which is actually a cross build.