cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Improve generating derivations for foreign architectures

Browse source 
Use the second argument to package-transitive-supported-systems to correctly
identify the different bootstrap path for non x86_64 and i686-linux. The
previous implementation did work, but only up until a merge of core-updates
changed the bootstrap approach.
This commit is contained in:
Christopher Baines 2019-12-31 08:44:12 +00:00
parent 2cb5309851
commit df9d0bbdd1
1 changed files with 65 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

107
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -353,59 +353,82 @@ WHERE job_id = $1"
(define (proc packages system-target-pairs) (define (proc packages system-target-pairs)
`(lambda (store) `(lambda (store)
(define package-transitive-supported-systems-supports-multiple-arguments? #t)
(define (get-supported-systems package system)
(or (and package-transitive-supported-systems-supports-multiple-arguments?
(catch
'wrong-number-of-args
(lambda ()
(package-transitive-supported-systems package system))
(lambda (key . args)
;; Older Guix revisions don't support two
;; arguments to
;; package-transitive-supported-systems
(simple-format
(current-error-port)
"info: package-transitive-supported-systems doesn't support two arguments, falling back to one\n")
(set! package-transitive-supported-systems-supports-multiple-arguments? #f)
#f)))
(catch
#t
(lambda ()
(package-transitive-supported-systems package))
(lambda (key . args)
(simple-format
(current-error-port)
"error: while processing ~A, unable to compute transitive supported systems\n"
(package-name package))
(simple-format
(current-error-port)
"error ~A: ~A\n" key args)
#f))))
(define (derivations-for-system-and-target inferior-package-id package system target)
(catch
'misc-error
(lambda ()
(guard (c ((package-cross-build-system-error? c)
#f))
(list inferior-package-id
system
target
(derivation-file-name
(if (string=? system target)
(package-derivation store package system)
(package-cross-derivation store package
target
system))))))
(lambda args
;; misc-error #f ~A ~S (No
;; cross-compilation for
;; clojure-build-system yet:
#f)))
(append-map (append-map
(lambda (inferior-package-id) (lambda (inferior-package-id)
(let ((package (hashv-ref %package-table inferior-package-id))) (let ((package (hashv-ref %package-table inferior-package-id)))
(catch (catch
#t #t
(lambda () (lambda ()
(let ((supported-systems (append-map
(catch (lambda (system)
#t (let ((supported-systems (get-supported-systems package system)))
(lambda () (if supported-systems
(package-transitive-supported-systems package))
(lambda (key . args)
(simple-format
(current-error-port)
"error: while processing ~A, unable to compute transitive supported systems\n"
(package-name package))
(simple-format
(current-error-port)
"error ~A: ~A\n" key args)
#f))))
(if supported-systems
(append-map
(lambda (system)
(filter-map (filter-map
(lambda (target) (lambda (target)
(catch (derivations-for-system-and-target inferior-package-id
'misc-error package
(lambda () system
(guard (c ((package-cross-build-system-error? c) target))
#f))
(list inferior-package-id
system
target
(derivation-file-name
(if (string=? system target)
(package-derivation store package system)
(package-cross-derivation store package
target
system))))))
(lambda args
;; misc-error #f ~A ~S (No
;; cross-compilation for
;; clojure-build-system yet:
#f)))
(lset-intersection (lset-intersection
string=? string=?
supported-systems supported-systems
(list ,@(map cdr system-target-pairs))))) (list ,@(map cdr system-target-pairs))))
(lset-intersection '())))
string=? (delete-duplicates
supported-systems (list ,@(map car system-target-pairs))
(list ,@(map car system-target-pairs)))) string=?)))
'())))
(lambda (key . args) (lambda (key . args)
(if (and (eq? key 'system-error) (if (and (eq? key 'system-error)
(eq? (car args) 'fport_write)) (eq? (car args) 'fport_write))