projects/guix·blob bootstrap-team · refs

604 lines · 23.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012-2024 Ludovic Courtès <[email protected]>
3;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <[email protected]>
4;;; Copyright © 2018, 2019 Clément Lassieur <[email protected]>
5;;; Copyright © 2020 Julien Lepiller <[email protected]>
6;;; Copyright © 2020, 2021 Mathieu Othacehe <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23(define-module (gnu ci)
24 #:use-module (guix build-system channel)
25 #:use-module (guix config)
26 #:autoload (guix describe) (package-channels)
27 #:use-module (guix memoization)
28 #:use-module (guix store)
29 #:use-module (guix profiles)
30 #:use-module (guix packages)
31 #:autoload (guix transformations) (tunable-package? tuned-package)
32 #:use-module (guix channels)
33 #:use-module (guix config)
34 #:use-module (guix derivations)
35 #:use-module (guix monads)
36 #:use-module (guix gexp)
37 #:use-module (guix ui)
38 #:use-module ((guix licenses)
39 #:select (gpl3+ license? license-name))
40 #:use-module ((guix utils) #:select (%current-system))
41 #:use-module ((guix scripts system) #:select (read-operating-system))
42 #:use-module ((guix scripts pack)
43 #:select (self-contained-tarball))
44 #:use-module (gnu bootloader)
45 #:use-module (gnu bootloader u-boot)
46 #:use-module (gnu compression)
47 #:use-module (gnu image)
48 #:use-module (gnu packages)
49 #:use-module (gnu packages gcc)
50 #:use-module (gnu packages gdb)
51 #:use-module (gnu packages base)
52 #:use-module (gnu packages gawk)
53 #:use-module (gnu packages guile)
54 #:use-module (gnu packages gettext)
55 #:use-module (gnu packages compression)
56 #:use-module (gnu packages multiprecision)
57 #:use-module (gnu packages make-bootstrap)
58 #:use-module (gnu packages package-management)
59 #:use-module (guix platform)
60 #:use-module (gnu system)
61 #:use-module (gnu system image)
62 #:use-module (gnu system vm)
63 #:use-module (gnu system install)
64 #:use-module (gnu system images hurd)
65 #:use-module (gnu system images novena)
66 #:use-module (gnu system images pine64)
67 #:use-module (gnu system images pinebook-pro)
68 #:use-module (gnu system images visionfive2)
69 #:use-module (gnu tests)
70 #:use-module (srfi srfi-1)
71 #:use-module (srfi srfi-26)
72 #:use-module (ice-9 match)
73 #:export (derivation->job
74 image->job
75
76 %core-packages
77
78 arguments->systems
79 cuirass-jobs))
80
81;;; Commentary:
82;;;
83;;; This file defines build jobs for Cuirass.
84;;;
85;;; Code:
86
87(define* (derivation->job name drv
88 #:key
89 (max-silent-time 3600)
90 (timeout (* 5 3600)))
91 "Return a Cuirass job called NAME and describing DRV.
92
93MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
94building the derivation."
95 `((#:job-name . ,name)
96 (#:derivation . ,(derivation-file-name drv))
97 (#:inputs . ,(map (compose derivation-file-name
98 derivation-input-derivation)
99 (derivation-inputs drv)))
100 (#:outputs . ,(filter-map
101 (lambda (res)
102 (match res
103 ((name . path)
104 `(,name . ,path))))
105 (derivation->output-paths drv)))
106 (#:nix-name . ,(derivation-name drv))
107 (#:system . ,(derivation-system drv))
108 (#:max-silent-time . ,max-silent-time)
109 (#:timeout . ,timeout)))
110
111(define* (package-job store job-name package system
112 #:key cross? target (suffix ""))
113 "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
114 (let ((job-name (string-append job-name "." system suffix)))
115 (parameterize ((%graft? #f))
116 (let* ((drv (if cross?
117 (package-cross-derivation store package target system
118 #:graft? #f)
119 (package-derivation store package system
120 #:graft? #f)))
121 (max-silent-time (or (assoc-ref (package-properties package)
122 'max-silent-time)
123 3600))
124 (timeout (or (assoc-ref (package-properties package)
125 'timeout)
126 72000)))
127 (derivation->job job-name drv
128 #:max-silent-time max-silent-time
129 #:timeout timeout)))))
130
131(define (package-cross-job store job-name package target system)
132 "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
133SYSTEM."
134 (let ((name (string-append target "." job-name)))
135 (package-job store name package system
136 #:cross? #t
137 #:target target)))
138
139(define %core-packages
140 ;; Note: Don't put the '-final' package variants because (1) that's
141 ;; implicit, and (2) they cannot be cross-built (due to the explicit input
142 ;; chain.)
143 (list gcc-10 gcc-11 gcc-12 glibc binutils gdb-minimal
144 gmp mpfr mpc coreutils findutils diffutils patch sed grep
145 gawk gnu-gettext hello guile-2.2 guile-3.0 zlib gzip xz guix
146 %bootstrap-binaries-tarball
147 %binutils-bootstrap-tarball
148 (%glibc-bootstrap-tarball)
149 %gcc-bootstrap-tarball
150 %guile-bootstrap-tarball
151 %bootstrap-tarballs))
152
153(define (commencement-packages system)
154 "Return the list of bootstrap packages from the commencement module for
155SYSTEM."
156 ;; Only include packages supported on SYSTEM. For example, the Mes
157 ;; bootstrap graph is currently not supported on ARM so it should be
158 ;; excluded.
159 (filter (lambda (obj)
160 (and (package? obj)
161 (supported-package? obj system)))
162 (module-map (lambda (sym var)
163 (variable-ref var))
164 (resolve-module '(gnu packages commencement)))))
165
166(define (packages-to-cross-build target)
167 "Return the list of packages to cross-build for TARGET."
168 ;; Don't cross-build the bootstrap tarballs for MinGW.
169 (if (string-contains target "mingw")
170 (drop-right %core-packages 6)
171 %core-packages))
172
173(define %bare-platform-triplets
174 ;; Cross-compilation triplets of platforms that lack a proper user-space and
175 ;; for which there's no point in trying to build regular packages.
176 '("avr"
177 "or1k-elf"
178 "xtensa-ath9k-elf"))
179
180(define %unsupported-platform-triplets
181 ;; These systems are kept around for nostalgia or for tinkering, but regular
182 ;; CI is disabled for them to reduce the load on CI infrastructure.
183 '("mips64el-linux-gnu"
184 "powerpc-linux-gnu"
185 "powerpc64-linux-gnu"))
186
187(define (cross-jobs store system)
188 "Return a list of cross-compilation jobs for SYSTEM."
189 (define (from-32-to-64? target)
190 ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
191 ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
192 ;; mips64el-linux-gnuabi64.
193 (and (or (string-prefix? "i686-" system)
194 (string-prefix? "i586-" system)
195 (string-prefix? "armhf-" system))
196 (string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
197
198 (define (same? target)
199 ;; Return true if SYSTEM and TARGET are the same thing. This is so we
200 ;; don't try to cross-compile to 'mips64el-linux-gnu' from
201 ;; 'mips64el-linux'.
202 (or (and (string-contains target system)
203 (not (string=? "x86_64-linux-gnux32" target)))
204 (and (string-prefix? "armhf" system) ;armhf-linux
205 (string-prefix? "arm" target)))) ;arm-linux-gnueabihf
206
207 (define (pointless? target)
208 ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
209 (or (member target %bare-platform-triplets)
210 (member target %unsupported-platform-triplets)
211 (match system
212 ((or "x86_64-linux" "i686-linux")
213 (if (string-contains target "mingw")
214 (not (string=? "x86_64-linux" system))
215 #f))
216 (_
217 ;; Don't try to cross-compile from non-Intel platforms: this isn't
218 ;; very useful and these are often brittle configurations.
219 #t))))
220
221 (define (either proc1 proc2 proc3)
222 (lambda (x)
223 (or (proc1 x) (proc2 x) (proc3 x))))
224
225 (append-map (lambda (target)
226 (map (lambda (package)
227 (package-cross-job store (job-name package)
228 package target system))
229 (packages-to-cross-build target)))
230 (remove (either from-32-to-64? same? pointless?)
231 (targets))))
232
233(define* (guix-jobs store systems #:key source commit)
234 "Return a list of jobs for Guix itself."
235 (define build
236 (primitive-load (string-append source "/build-aux/build-self.scm")))
237
238 (map
239 (lambda (system)
240 (let ((name (string->symbol
241 (string-append "guix." system)))
242 (drv (run-with-store store
243 (build source #:version commit #:system system
244 #:pull-version 1
245 #:guile-version "2.2"))))
246 (derivation->job name drv)))
247 systems))
248
249;; Architectures that are able to build or cross-build Guix System images.
250;; This does not mean that other architectures are not supported, only that
251;; they are often not fast enough to support Guix System images building.
252(define %guix-system-supported-systems
253 '("x86_64-linux" "i686-linux"))
254
255(define %guix-system-images
256 (list hurd-barebones-qcow2-image
257 pine64-barebones-raw-image
258 pinebook-pro-barebones-raw-image
259 novena-barebones-raw-image
260 visionfive2-barebones-raw-image))
261
262(define (hours hours)
263 (* 3600 hours))
264
265(define* (image->job store image
266 #:key name system)
267 "Return the job for IMAGE on SYSTEM. If NAME is passed, use it as job name,
268otherwise use the IMAGE name."
269 (let* ((image-name (or name
270 (symbol->string (image-name image))))
271 (name (string-append image-name "." system))
272 (drv (run-with-store store
273 (mbegin %store-monad
274 (set-guile-for-build (default-guile))
275 (lower-object (system-image image) system)))))
276 (parameterize ((%graft? #f))
277 (derivation->job name drv))))
278
279(define* (image-jobs store system
280 #:key source commit)
281 "Return a list of jobs that build images for SYSTEM."
282 (define MiB
283 (expt 2 20))
284
285 (parameterize ((current-guix-package
286 (channel-source->package source #:commit commit)))
287 (if (member system %guix-system-supported-systems)
288 `(,(image->job store
289 (image
290 (inherit mbr-hybrid-disk-image)
291 (operating-system installation-os))
292 #:name "usb-image"
293 #:system system)
294 ,(image->job
295 store
296 (image
297 (inherit (image-with-label
298 iso9660-image
299 (string-append "GUIX_" system "_"
300 (if (> (string-length %guix-version) 7)
301 (substring %guix-version 0 7)
302 %guix-version))))
303 (operating-system installation-os))
304 #:name "iso9660-image"
305 #:system system)
306 ;; Only cross-compile Guix System images from x86_64-linux for now.
307 ,@(if (string=? system "x86_64-linux")
308 (map (cut image->job store <>
309 #:system system)
310 %guix-system-images)
311 '()))
312 '())))
313
314(define* (system-test-jobs store system
315 #:key source commit)
316 "Return a list of jobs for the system tests."
317 (define (->job test)
318 (let ((name (string-append "test." (system-test-name test)
319 "." system))
320 (drv (run-with-store store
321 (mbegin %store-monad
322 (set-current-system system)
323 (set-grafting #f)
324 (set-guile-for-build (default-guile))
325 (system-test-value test)))))
326
327 (derivation->job name drv)))
328
329 (if (member system %guix-system-supported-systems)
330 ;; Override the value of 'current-guix' used by system tests. Using a
331 ;; channel instance makes tests that rely on 'current-guix' less
332 ;; expensive. It also makes sure we get a valid Guix package when this
333 ;; code is not running from a checkout.
334 (parameterize ((current-guix-package
335 (channel-source->package source #:commit commit)))
336 (map ->job (all-system-tests)))
337 '()))
338
339(define (tarball-jobs store system)
340 "Return jobs to build the self-contained Guix binary tarball."
341 (define (->job name drv)
342 (let ((name (string-append name "." system)))
343 (parameterize ((%graft? #f))
344 (derivation->job name drv))))
345
346 ;; XXX: Add a job for the stable Guix?
347 (list
348 (->job "binary-tarball"
349 (run-with-store store
350 (mbegin %store-monad
351 (set-guile-for-build (default-guile))
352 (>>= (profile-derivation (packages->manifest (list guix)))
353 (lambda (profile)
354 (self-contained-tarball "guix-binary" profile
355 #:profile-name "current-guix"
356 #:localstatedir? #t
357 #:compressor
358 (lookup-compressor "xz")))))
359 #:system system))))
360
361(define job-name
362 ;; Return the name of a package's job.
363 package-name)
364
365(define base-packages
366 (mlambda (system)
367 "Return the set of packages considered to be part of the base for SYSTEM."
368 (delete-duplicates
369 (append-map (match-lambda
370 ((_ package _ ...)
371 (match (package-transitive-inputs package)
372 (((_ inputs _ ...) ...)
373 inputs))))
374 (%final-inputs system)))))
375
376(define package->job
377 (lambda* (store package system #:key (suffix ""))
378 "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
379valid. Append SUFFIX to the job name."
380 (cond ((member package (base-packages system))
381 (package-job store (string-append "base." (job-name package))
382 package system #:suffix suffix))
383 ((supported-package? package system)
384 (let ((drv (package-derivation store package system
385 #:graft? #f)))
386 (and (substitutable-derivation? drv)
387 (package-job store (job-name package)
388 package system #:suffix suffix))))
389 (else
390 #f))))
391
392(define %x86-64-micro-architectures
393 ;; Micro-architectures for which we build tuned variants.
394 '("haswell" "skylake" "x86-64-v2" "x86-64-v3" "x86-64-v4"))
395
396(define (tuned-package-jobs store package system)
397 "Return a list of jobs for PACKAGE tuned for SYSTEM's micro-architectures."
398 (filter-map (lambda (micro-architecture)
399 (define suffix
400 (string-append "." micro-architecture))
401
402 (package->job store
403 (tuned-package package micro-architecture)
404 system
405 #:suffix suffix))
406 (match system
407 ("x86_64-linux" %x86-64-micro-architectures)
408 (_ '()))))
409
410(define (all-packages)
411 "Return the list of packages to build."
412 (define (adjust package result)
413 (cond ((package-replacement package)
414 ;; XXX: If PACKAGE and its replacement have the same name/version,
415 ;; then both Cuirass jobs will have the same name, which
416 ;; effectively means that the second one will be ignored. Thus,
417 ;; return the replacement first.
418 (cons* (package-replacement package) ;build both
419 package
420 result))
421 ((package-superseded package)
422 result) ;don't build it
423 (else
424 (cons package result))))
425
426 (fold-packages adjust
427 (fold adjust '() ;include base packages
428 (match (%final-inputs)
429 (((labels packages _ ...) ...)
430 packages)))
431 #:select? (const #t))) ;include hidden packages
432
433(define (arguments->manifests arguments channels)
434 "Return the list of manifests extracted from ARGUMENTS."
435 (map (lambda (manifest)
436 (any (lambda (checkout)
437 (let ((path (in-vicinity checkout manifest)))
438 (and (file-exists? path)
439 path)))
440 (map channel-url channels)))
441 arguments))
442
443(define (manifests->jobs store manifests systems)
444 "Return the list of jobs for the entries in MANIFESTS, a list of file
445names, for each one of SYSTEMS."
446 (define (load-manifest manifest)
447 (save-module-excursion
448 (lambda ()
449 (set-current-module (make-user-module '((guix profiles) (gnu))))
450 (primitive-load manifest))))
451
452 (define (manifest-entry-job-name entry)
453 (string-append (manifest-entry-name entry) "-"
454 (manifest-entry-version entry)))
455
456 (define (manifest-entry->job entry system)
457 (let* ((obj (manifest-entry-item entry))
458 (drv (parameterize ((%graft? #f))
459 (run-with-store store
460 (lower-object obj system)
461 #:system system)))
462 (max-silent-time (or (and (package? obj)
463 (assoc-ref (package-properties obj)
464 'max-silent-time))
465 3600))
466 (timeout (or (and (package? obj)
467 (assoc-ref (package-properties obj) 'timeout))
468 (* 5 3600))))
469 (derivation->job (manifest-entry-job-name entry) drv
470 #:max-silent-time max-silent-time
471 #:timeout timeout)))
472
473 (let ((entries (delete-duplicates
474 (append-map (compose manifest-entries load-manifest)
475 manifests)
476 manifest-entry=?)))
477 (append-map (lambda (system)
478 (map (cut manifest-entry->job <> system) entries))
479 systems)))
480
481(define (arguments->systems arguments)
482 "Return the systems list from ARGUMENTS."
483 (match (assoc-ref arguments 'systems)
484 (#f %cuirass-supported-systems)
485 ((lst ...) lst)
486 ((? string? str) (call-with-input-string str read))))
487
488
489;;;
490;;; Cuirass entry point.
491;;;
492
493(define (cuirass-jobs store arguments)
494 "Register Cuirass jobs."
495 (define subset
496 (assoc-ref arguments 'subset))
497
498 (define systems
499 (arguments->systems arguments))
500
501 (define channels
502 (let ((channels (assq-ref arguments 'channels)))
503 (map sexp->channel channels)))
504
505 (define guix
506 (find guix-channel? channels))
507
508 (define commit
509 (channel-commit guix))
510
511 (define source
512 (channel-url guix))
513
514 ;; Turn off grafts. Grafting is meant to happen on the user's machines.
515 (parameterize ((%graft? #f))
516 ;; Return one job for each package, except bootstrap packages.
517 (append-map
518 (lambda (system)
519 (format (current-error-port)
520 "evaluating for '~a' (heap size: ~a MiB)...~%"
521 system
522 (round
523 (/ (assoc-ref (gc-stats) 'heap-size)
524 (expt 2. 20))))
525 (invalidate-derivation-caches!)
526 (match subset
527 ('all
528 ;; Build everything, including replacements.
529 (let ((all (all-packages))
530 (jobs (lambda (package)
531 (match (package->job store package system)
532 (#f '())
533 (main-job
534 (cons main-job
535 (if (tunable-package? package)
536 (tuned-package-jobs store package system)
537 '())))))))
538 (append
539 (append-map jobs all)
540 (cross-jobs store system))))
541 ('core
542 ;; Build core packages only.
543 (append
544 (map (lambda (package)
545 (package-job store (job-name package)
546 package system))
547 (append (commencement-packages system) %core-packages))
548 (cross-jobs store system)))
549 ('guix
550 ;; Build Guix modules only.
551 (guix-jobs store systems
552 #:source source
553 #:commit commit))
554 ('hello
555 ;; Build hello package only.
556 (let ((hello (specification->package "hello")))
557 (list (package-job store (job-name hello)
558 hello system))))
559 ('images
560 ;; Build Guix System images only.
561 (image-jobs store system
562 #:source source
563 #:commit commit))
564 ('system-tests
565 ;; Build Guix System tests only.
566 (system-test-jobs store system
567 #:source source
568 #:commit commit))
569 ('tarball
570 ;; Build Guix tarball only.
571 (tarball-jobs store system))
572 (('custom . modules)
573 ;; Build custom modules jobs only.
574 (append-map
575 (lambda (module)
576 (let ((proc (module-ref
577 (resolve-interface module)
578 'cuirass-jobs)))
579 (proc store arguments)))
580 modules))
581 (('channels . channels)
582 ;; Build only the packages from CHANNELS.
583 (let ((all (all-packages)))
584 (filter-map
585 (lambda (package)
586 (any (lambda (channel)
587 (and (member (channel-name channel) channels)
588 (package->job store package system)))
589 (package-channels package)))
590 all)))
591 (('packages . rest)
592 ;; Build selected list of packages only.
593 (let ((packages (map specification->package rest)))
594 (map (lambda (package)
595 (package-job store (job-name package)
596 package system))
597 packages)))
598 (('manifests . rest)
599 ;; Build packages in the list of manifests.
600 (let ((manifests (arguments->manifests rest channels)))
601 (manifests->jobs store manifests systems)))
602 (else
603 (error "unknown subset" subset))))
604 systems)))