X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/075df3d3e2f86ad2548075969b34402a3c40ec42..ae221813745783ef1b7eee47561a2208cd5ad512:/gnu/ci.scm diff --git a/gnu/ci.scm b/gnu/ci.scm index 283b7e34f4..19a48bdbf1 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -21,28 +21,28 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu ci) - #:use-module (guix channels) + #:use-module (guix build-system channel) #:use-module (guix config) - #:use-module (guix describe) + #:autoload (guix describe) (package-channels) #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix profiles) #:use-module (guix packages) + #:autoload (guix transformations) (tunable-package? tuned-package) #:use-module (guix channels) #:use-module (guix config) #:use-module (guix derivations) - #:use-module (guix build-system) #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix ui) #:use-module ((guix licenses) #:select (gpl3+ license? license-name)) #:use-module ((guix utils) #:select (%current-system)) - #:use-module ((guix scripts system) #:select (read-operating-system)) #:use-module ((guix scripts pack) - #:select (lookup-compressor self-contained-tarball)) + #:select (self-contained-tarball)) #:use-module (gnu bootloader) #:use-module (gnu bootloader u-boot) + #:use-module (gnu compression) #:use-module (gnu image) #:use-module (gnu packages) #:use-module (gnu packages gcc) @@ -54,6 +54,7 @@ #:use-module (gnu packages multiprecision) #:use-module (gnu packages make-bootstrap) #:use-module (gnu packages package-management) + #:use-module (guix platform) #:use-module (gnu system) #:use-module (gnu system image) #:use-module (gnu system vm) @@ -70,8 +71,6 @@ image->job %core-packages - %cross-targets - channel-source->package arguments->systems cuirass-jobs)) @@ -107,9 +106,9 @@ building the derivation." (#:timeout . ,timeout))) (define* (package-job store job-name package system - #:key cross? target) + #:key cross? target (suffix "")) "Return a job called JOB-NAME that builds PACKAGE on SYSTEM." - (let ((job-name (string-append job-name "." system))) + (let ((job-name (string-append job-name "." system suffix))) (parameterize ((%graft? #f)) (let* ((drv (if cross? (package-cross-derivation store package target system @@ -140,7 +139,7 @@ SYSTEM." ;; chain.) (list gcc-8 gcc-9 gcc-10 gcc-11 glibc binutils gmp mpfr mpc coreutils findutils diffutils patch sed grep - gawk gnu-gettext hello guile-2.2 guile-3.0 zlib gzip xz + gawk gnu-gettext hello guile-2.2 guile-3.0 zlib gzip xz guix %bootstrap-binaries-tarball %binutils-bootstrap-tarball (%glibc-bootstrap-tarball) @@ -168,17 +167,6 @@ SYSTEM." (drop-right %core-packages 6) %core-packages)) -(define %cross-targets - '("mips64el-linux-gnu" - "arm-linux-gnueabihf" - "aarch64-linux-gnu" - "powerpc-linux-gnu" - "powerpc64le-linux-gnu" - "riscv64-linux-gnu" - "i586-pc-gnu" ;aka. GNU/Hurd - "i686-w64-mingw32" - "x86_64-w64-mingw32")) - (define (cross-jobs store system) "Return a list of cross-compilation jobs for SYSTEM." (define (from-32-to-64? target) @@ -220,7 +208,7 @@ SYSTEM." package target system)) (packages-to-cross-build target))) (remove (either from-32-to-64? same? pointless?) - %cross-targets))) + (targets)))) (define* (guix-jobs store systems #:key source commit) "Return a list of jobs for Guix itself." @@ -267,73 +255,40 @@ otherwise use the IMAGE name." (parameterize ((%graft? #f)) (derivation->job name drv)))) -(define (image-jobs store system) +(define* (image-jobs store system + #:key source commit) "Return a list of jobs that build images for SYSTEM." (define MiB (expt 2 20)) - (if (member system %guix-system-supported-systems) - `(,(image->job store - (image - (inherit efi-disk-image) - (operating-system installation-os)) - #:name "usb-image" - #:system system) - ,(image->job - store - (image - (inherit (image-with-label - iso9660-image - (string-append "GUIX_" system "_" - (if (> (string-length %guix-version) 7) - (substring %guix-version 0 7) - %guix-version)))) - (operating-system installation-os)) - #:name "iso9660-image" - #:system system) - ;; Only cross-compile Guix System images from x86_64-linux for now. - ,@(if (string=? system "x86_64-linux") - (map (cut image->job store <> - #:system system) - %guix-system-images) - '())) - '())) - -(define channel-build-system - ;; Build system used to "convert" a channel instance to a package. - (let* ((build (lambda* (name inputs - #:key source commit system - #:allow-other-keys) - (mlet* %store-monad ((source (if (string? source) - (return source) - (lower-object source))) - (instance - -> (checkout->channel-instance - source #:commit commit))) - (channel-instances->derivation (list instance))))) - (lower (lambda* (name #:key system source commit - #:allow-other-keys) - (bag - (name name) - (system system) - (build build) - (arguments `(#:source ,source - #:commit ,commit)))))) - (build-system (name 'channel) - (description "Turn a channel instance into a package.") - (lower lower)))) - -(define* (channel-source->package source #:key commit) - "Return a package for the given channel SOURCE, a lowerable object." - (package - (inherit guix) - (version (string-append (package-version guix) "+")) - (build-system channel-build-system) - (arguments `(#:source ,source - #:commit ,commit)) - (inputs '()) - (native-inputs '()) - (propagated-inputs '()))) + (parameterize ((current-guix-package + (channel-source->package source #:commit commit))) + (if (member system %guix-system-supported-systems) + `(,(image->job store + (image + (inherit efi-disk-image) + (operating-system installation-os)) + #:name "usb-image" + #:system system) + ,(image->job + store + (image + (inherit (image-with-label + iso9660-image + (string-append "GUIX_" system "_" + (if (> (string-length %guix-version) 7) + (substring %guix-version 0 7) + %guix-version)))) + (operating-system installation-os)) + #:name "iso9660-image" + #:system system) + ;; Only cross-compile Guix System images from x86_64-linux for now. + ,@(if (string=? system "x86_64-linux") + (map (cut image->job store <> + #:system system) + %guix-system-images) + '())) + '()))) (define* (system-test-jobs store system #:key source commit) @@ -395,21 +350,39 @@ otherwise use the IMAGE name." (((_ inputs _ ...) ...) inputs)))) (%final-inputs))))) - (lambda (store package system) + (lambda* (store package system #:key (suffix "")) "Return a job for PACKAGE on SYSTEM, or #f if this combination is not -valid." +valid. Append SUFFIX to the job name." (cond ((member package base-packages) (package-job store (string-append "base." (job-name package)) - package system)) + package system #:suffix suffix)) ((supported-package? package system) (let ((drv (package-derivation store package system #:graft? #f))) (and (substitutable-derivation? drv) (package-job store (job-name package) - package system)))) + package system #:suffix suffix)))) (else #f))))) +(define %x86-64-micro-architectures + ;; Micro-architectures for which we build tuned variants. + '("westmere" "ivybridge" "haswell" "skylake" "skylake-avx512")) + +(define (tuned-package-jobs store package system) + "Return a list of jobs for PACKAGE tuned for SYSTEM's micro-architectures." + (filter-map (lambda (micro-architecture) + (define suffix + (string-append "." micro-architecture)) + + (package->job store + (tuned-package package micro-architecture) + system + #:suffix suffix)) + (match system + ("x86_64-linux" %x86-64-micro-architectures) + (_ '())))) + (define (all-packages) "Return the list of packages to build." (define (adjust package result) @@ -527,10 +500,16 @@ names." ('all ;; Build everything, including replacements. (let ((all (all-packages)) - (job (lambda (package) - (package->job store package system)))) + (jobs (lambda (package) + (match (package->job store package system) + (#f '()) + (main-job + (cons main-job + (if (tunable-package? package) + (tuned-package-jobs store package system) + '()))))))) (append - (filter-map job all) + (append-map jobs all) (cross-jobs store system)))) ('core ;; Build core packages only. @@ -552,7 +531,9 @@ names." hello system)))) ('images ;; Build Guix System images only. - (image-jobs store system)) + (image-jobs store system + #:source source + #:commit commit)) ('system-tests ;; Build Guix System tests only. (system-test-jobs store system