system: vm: Non-volatile 'run-vm.sh' creates a CoW image.

Previously, copying the image would consume a lot of space and was
I/O-intensive, to the point that the marionette connection timeout of
20s could be reached when running tests like "docker-system".

* gnu/system/vm.scm (common-qemu-options): Pass 'format=' for each
'-drive' option.
(system-qemu-image/shared-store-script)[copy-image]: New variable.
[builder]: Use it when VOLATILE? is false.
This commit is contained in:
Ludovic Courtès 2022-12-06 15:06:35 +01:00
parent 2493de0d1a
commit f59aa79ca3
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5

View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org> ;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@ -234,8 +234,8 @@ (define (virtfs-option fs)
#$@(map virtfs-option shared-fs) #$@(map virtfs-option shared-fs)
#$@(if rw-image? #$@(if rw-image?
#~((format #f "-drive file=~a,if=virtio" #$image)) #~((format #f "-drive file=~a,format=qcow2,if=virtio" #$image))
#~((format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on" #~((format #f "-drive file=~a,format=raw,if=virtio,cache=writeback,werror=report,readonly=on"
#$image))))) #$image)))))
(define* (system-qemu-image/shared-store-script os (define* (system-qemu-image/shared-store-script os
@ -303,17 +303,26 @@ (define qemu-exec
"-m " (number->string #$memory-size) "-m " (number->string #$memory-size)
#$@options)) #$@options))
(define copy-image
;; Script that "copies" BASE-IMAGE to /tmp. Make a copy-on-write image,
;; which is much cheaper than actually copying it.
(program-file "copy-image"
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
(unless (file-exists? #$rw-image)
(invoke #+(file-append qemu "/bin/qemu-img")
"create" "-b" #$base-image
"-F" "raw" "-f" "qcow2" #$rw-image))))))
(define builder (define builder
#~(call-with-output-file #$output #~(call-with-output-file #$output
(lambda (port) (lambda (port)
(format port "#!~a~%" (format port "#!~a~%"
#+(file-append bash "/bin/sh")) #+(file-append bash "/bin/sh"))
(when (not #$volatile?) #$@(if volatile?
(format port "~a~%" #~()
#$(program-file "copy-image" #~((format port "~a~%" #+copy-image)))
#~(unless (file-exists? #$rw-image)
(copy-file #$base-image #$rw-image)
(chmod #$rw-image #o640)))))
(format port "exec ~a \"$@\"~%" (format port "exec ~a \"$@\"~%"
(string-join #$qemu-exec " ")) (string-join #$qemu-exec " "))
(chmod port #o555)))) (chmod port #o555))))