me/guix
Archived
1
0
Fork 0
Code Activity

gnu: QEMU: Use G-expression.

Browse source 
* gnu/packages/virtualization.scm (qemu, qemu-minimal)[arguments]: Rewrite
with G-expressions.
This commit is contained in:
Marius Bakke 2022-09-09 20:18:59 +02:00
parent 0f6f9317ac
commit b15c0e75f9
No known key found for this signature in database
GPG key ID: A2A06DF2A33A54FA
1 changed files with 149 additions and 148 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

297
gnu/packages/virtualization.scm
View file

@ -177,154 +177,155 @@
(outputs '("out" "static" "doc")) ;5.3 MiB of HTML docs (outputs '("out" "static" "doc")) ;5.3 MiB of HTML docs
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
;; FIXME: Disable tests on i686 to work around (list
;; <https://bugs.gnu.org/40527>. ;; FIXME: Disable tests on i686 to work around
`(#:tests? ,(or (%current-target-system) ;; <https://bugs.gnu.org/40527>.
(not (string=? "i686-linux" (%current-system)))) #:tests? (or (%current-target-system)
#:configure-flags (not (string=? "i686-linux" (%current-system))))
(let ((gcc (search-input-file %build-inputs "/bin/gcc")) #:configure-flags
(out (assoc-ref %outputs "out"))) #~(let ((gcc (search-input-file %build-inputs "/bin/gcc"))
(list (string-append "--cc=" gcc) (out #$output))
;; Some architectures insist on using HOST_CC. (list (string-append "--cc=" gcc)
(string-append "--host-cc=" gcc) ;; Some architectures insist on using HOST_CC.
(string-append "--prefix=" out) (string-append "--host-cc=" gcc)
"--sysconfdir=/etc" (string-append "--prefix=" out)
(string-append "--smbd=" out "/libexec/samba-wrapper") "--sysconfdir=/etc"
"--disable-debug-info" ;for space considerations (string-append "--smbd=" out "/libexec/samba-wrapper")
;; The binaries need to be linked against -lrt. "--disable-debug-info" ;for space considerations
(string-append "--extra-ldflags=-lrt"))) ;; The binaries need to be linked against -lrt.
;; Make build and test output verbose to facilitate investigation upon failure. (string-append "--extra-ldflags=-lrt")))
#:make-flags '("V=1") ;; Make build and test output verbose to facilitate investigation upon failure.
#:modules ((srfi srfi-1) #:make-flags #~'("V=1")
#:modules `((srfi srfi-1)
(srfi srfi-26) (srfi srfi-26)
(ice-9 ftw) (ice-9 ftw)
(ice-9 match) (ice-9 match)
,@%gnu-build-system-modules) ,@%gnu-build-system-modules)
#:phases #:phases
(modify-phases %standard-phases #~(modify-phases %standard-phases
(add-after 'unpack 'extend-test-time-outs (add-after 'unpack 'extend-test-time-outs
(lambda _ (lambda _
;; These tests can time out on heavily-loaded and/or slow storage. ;; These tests can time out on heavily-loaded and/or slow storage.
(substitute* (cons* "tests/qemu-iotests/common.qemu" (substitute* (cons* "tests/qemu-iotests/common.qemu"
(find-files "tests/qemu-iotests" "^[0-9]+$")) (find-files "tests/qemu-iotests" "^[0-9]+$"))
(("QEMU_COMM_TIMEOUT=[0-9]+" match) (("QEMU_COMM_TIMEOUT=[0-9]+" match)
(string-append match "9"))))) (string-append match "9")))))
(add-after 'unpack 'disable-unusable-tests (add-after 'unpack 'disable-unusable-tests
(lambda _ (lambda _
(substitute* "tests/unit/meson.build" (substitute* "tests/unit/meson.build"
;; Comment out the test-qga test, which needs /sys and ;; Comment out the test-qga test, which needs /sys and
;; fails within the build environment. ;; fails within the build environment.
(("tests.*test-qga.*$" all) (("tests.*test-qga.*$" all)
(string-append "# " all)) (string-append "# " all))
;; Comment out the test-char test, which needs networking and ;; Comment out the test-char test, which needs networking and
;; fails within the build environment. ;; fails within the build environment.
((".*'test-char':.*" all) ((".*'test-char':.*" all)
(string-append "# " all))))) (string-append "# " all)))))
,@(if (target-riscv64?) #$@(if (target-riscv64?)
`((add-after 'unpack 'disable-some-tests '((add-after 'unpack 'disable-some-tests
(lambda _ (lambda _
;; qemu.qmp.QMPConnectError: Unexpected empty reply from server ;; qemu.qmp.QMPConnectError:
(delete-file "tests/qemu-iotests/040") ;; Unexpected empty reply from server
(delete-file "tests/qemu-iotests/041") (delete-file "tests/qemu-iotests/040")
(delete-file "tests/qemu-iotests/256") (delete-file "tests/qemu-iotests/041")
(delete-file "tests/qemu-iotests/256")
;; No 'PCI' bus found for device 'virtio-scsi-pci' ;; No 'PCI' bus found for device 'virtio-scsi-pci'
(delete-file "tests/qemu-iotests/127") (delete-file "tests/qemu-iotests/127")
(delete-file "tests/qemu-iotests/267")))) (delete-file "tests/qemu-iotests/267"))))
'()) '())
(add-after 'patch-source-shebangs 'patch-embedded-shebangs (add-after 'patch-source-shebangs 'patch-embedded-shebangs
(lambda* (#:key native-inputs inputs #:allow-other-keys) (lambda* (#:key native-inputs inputs #:allow-other-keys)
;; Ensure the executables created by these source files reference ;; Ensure the executables created by these source files reference
;; /bin/sh from the store so they work inside the build container. ;; /bin/sh from the store so they work inside the build container.
(substitute* '("block/cloop.c" "migration/exec.c" (substitute* '("block/cloop.c" "migration/exec.c"
"net/tap.c" "tests/qtest/libqtest.c" "net/tap.c" "tests/qtest/libqtest.c"
"tests/qtest/vhost-user-blk-test.c") "tests/qtest/vhost-user-blk-test.c")
(("/bin/sh") (search-input-file inputs "/bin/sh"))) (("/bin/sh") (search-input-file inputs "/bin/sh")))
(substitute* "tests/qemu-iotests/testenv.py" (substitute* "tests/qemu-iotests/testenv.py"
(("#!/usr/bin/env python3") (("#!/usr/bin/env python3")
(string-append "#!" (search-input-file (or native-inputs inputs) (string-append "#!" (search-input-file (or native-inputs inputs)
"/bin/python3")))))) "/bin/python3"))))))
(add-before 'configure 'fix-optionrom-makefile (add-before 'configure 'fix-optionrom-makefile
(lambda _ (lambda _
;; Work around the inability of the rules defined in this ;; Work around the inability of the rules defined in this
;; Makefile to locate the firmware files (e.g.: No rule to make ;; Makefile to locate the firmware files (e.g.: No rule to make
;; target 'multiboot.bin') by extending the VPATH. ;; target 'multiboot.bin') by extending the VPATH.
(substitute* "pc-bios/optionrom/Makefile" (substitute* "pc-bios/optionrom/Makefile"
(("^VPATH = \\$\\(SRC_DIR\\)") (("^VPATH = \\$\\(SRC_DIR\\)")
"VPATH = $(SRC_DIR):$(TOPSRC_DIR)/pc-bios")))) "VPATH = $(SRC_DIR):$(TOPSRC_DIR)/pc-bios"))))
;; XXX ./configure is being re-run at beginning of build phase... ;; XXX ./configure is being re-run at beginning of build phase...
(replace 'configure (replace 'configure
(lambda* (#:key inputs outputs configure-flags #:allow-other-keys) (lambda* (#:key inputs configure-flags #:allow-other-keys)
;; The `configure' script doesn't understand some of the ;; The `configure' script doesn't understand some of the
;; GNU options. Thus, add a new phase that's compatible. ;; GNU options. Thus, add a new phase that's compatible.
(let ((out (assoc-ref outputs "out"))) (setenv "SHELL" (which "bash"))
(setenv "SHELL" (which "bash")) ;; Ensure config.status gets the correct shebang off the bat.
;; Ensure config.status gets the correct shebang off the bat. ;; The build system gets confused if we change it later and
;; The build system gets confused if we change it later and ;; attempts to re-run the whole configuration, and fails.
;; attempts to re-run the whole configuration, and fails. (substitute* "configure"
(substitute* "configure" (("#!/bin/sh")
(("#!/bin/sh") (string-append "#!" (which "sh"))))
(string-append "#!" (which "sh")))) (mkdir-p "b/qemu")
(mkdir-p "b/qemu") (chdir "b/qemu")
(chdir "b/qemu") (apply invoke "../../configure" configure-flags)))
(apply invoke "../../configure" configure-flags)))) ;; Configure, build and install QEMU user-emulation static binaries.
;; Configure, build and install QEMU user-emulation static binaries. (add-after 'configure 'configure-user-static
(add-after 'configure 'configure-user-static (lambda* (#:key inputs outputs #:allow-other-keys)
(lambda* (#:key inputs outputs #:allow-other-keys) (let* ((static (assoc-ref outputs "static"))
(let* ((gcc (search-input-file inputs "/bin/gcc")) (gcc (search-input-file inputs "/bin/gcc"))
(static (assoc-ref outputs "static")) ;; This is the common set of configure flags; it is
;; This is the common set of configure flags; it is ;; duplicated here to isolate this phase from manipulations
;; duplicated here to isolate this phase from manipulations ;; to the #:configure-flags build argument, as done in
;; to the #:configure-flags build argument, as done in ;; derived packages such as qemu-minimal.
;; derived packages such as qemu-minimal. (configure-flags (list (string-append "--cc=" gcc)
(configure-flags (list (string-append "--cc=" gcc) (string-append "--host-cc=" gcc)
(string-append "--host-cc=" gcc) "--sysconfdir=/etc"
"--sysconfdir=/etc" "--disable-debug-info")))
"--disable-debug-info"))) (mkdir-p "../user-static")
(mkdir-p "../user-static") (with-directory-excursion "../user-static"
(with-directory-excursion "../user-static" (apply invoke "../../configure"
(apply invoke "../../configure" "--static"
"--static" "--disable-docs" ;already built
"--disable-docs" ;already built "--disable-system"
"--disable-system" "--enable-linux-user"
"--enable-linux-user" (string-append "--prefix=" static)
(string-append "--prefix=" static) configure-flags)))))
configure-flags))))) (add-after 'build 'build-user-static
(add-after 'build 'build-user-static (lambda args
(lambda args (with-directory-excursion "../user-static"
(with-directory-excursion "../user-static" (apply (assoc-ref %standard-phases 'build) args))))
(apply (assoc-ref %standard-phases 'build) args)))) (add-after 'install 'install-user-static
(add-after 'install 'install-user-static (lambda* (#:key outputs #:allow-other-keys)
(lambda* (#:key outputs #:allow-other-keys) (let* ((static (assoc-ref outputs "static"))
(let* ((static (assoc-ref outputs "static")) (bin (string-append static "/bin")))
(bin (string-append static "/bin"))) (with-directory-excursion "../user-static"
(with-directory-excursion "../user-static" (for-each (cut install-file <> bin)
(for-each (cut install-file <> bin) (append-map (cut find-files <> "^qemu-" #:stat stat)
(append-map (cut find-files <> "^qemu-" #:stat stat) (scandir "."
(scandir "." (cut string-suffix?
(cut string-suffix? "-linux-user" <>))))))))
"-linux-user" <>)))))))) ;; Create a wrapper for Samba. This allows QEMU to use Samba without
;; Create a wrapper for Samba. This allows QEMU to use Samba without ;; pulling it in as an input. Note that you need to explicitly install
;; pulling it in as an input. Note that you need to explicitly install ;; Samba in your Guix profile for Samba support.
;; Samba in your Guix profile for Samba support. (add-after 'install 'create-samba-wrapper
(add-after 'install 'create-samba-wrapper (lambda* (#:key inputs #:allow-other-keys)
(lambda* (#:key inputs outputs #:allow-other-keys) (let ((libexec (string-append #$output "/libexec")))
(let* ((out (assoc-ref outputs "out")) (call-with-output-file "samba-wrapper"
(libexec (string-append out "/libexec"))) (lambda (port)
(call-with-output-file "samba-wrapper" (format port "#!/bin/sh
(lambda (port)
(format port "#!/bin/sh
exec smbd $@"))) exec smbd $@")))
(chmod "samba-wrapper" #o755) (chmod "samba-wrapper" #o755)
(install-file "samba-wrapper" libexec)))) (install-file "samba-wrapper" libexec))))
(add-after 'install 'move-html-doc (add-after 'install 'move-html-doc
(lambda* (#:key inputs outputs #:allow-other-keys) (lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out")) (let* ((out #$output)
(doc (assoc-ref outputs "doc")) (doc #$output:doc)
(qemu-doc (string-append doc "/share/doc/qemu-" ,version))) (qemu-doc (string-append doc "/share/doc/qemu-"
(mkdir-p qemu-doc) #$(package-version this-package))))
(rename-file (string-append out "/share/doc/qemu") (mkdir-p qemu-doc)
(string-append qemu-doc "/html")))))))) (rename-file (string-append out "/share/doc/qemu")
(string-append qemu-doc "/html"))))))))
(inputs (inputs
(list alsa-lib (list alsa-lib
bash-minimal bash-minimal
@ -405,7 +406,7 @@ server and embedded PowerPC, and S390 guests.")
"Machine emulator and virtualizer (without GUI) for the host architecture") "Machine emulator and virtualizer (without GUI) for the host architecture")
(arguments (arguments
(substitute-keyword-arguments (package-arguments qemu) (substitute-keyword-arguments (package-arguments qemu)
((#:configure-flags configure-flags '(list)) ((#:configure-flags configure-flags #~'())
;; Restrict to the host's architecture. ;; Restrict to the host's architecture.
(let* ((system (or (%current-target-system) (let* ((system (or (%current-target-system)
(%current-system))) (%current-system)))
@ -436,12 +437,12 @@ server and embedded PowerPC, and S390 guests.")
"--target-list=riscv32-softmmu,riscv64-softmmu") "--target-list=riscv32-softmmu,riscv64-softmmu")
(else ; An empty list actually builds all the targets. (else ; An empty list actually builds all the targets.
'())))) '()))))
`(cons ,target-list-arg ,configure-flags))) #~(cons #$target-list-arg #$configure-flags)))
((#:phases phases) ((#:phases phases)
`(modify-phases ,phases #~(modify-phases #$phases
(delete 'configure-user-static) (delete 'configure-user-static)
(delete 'build-user-static) (delete 'build-user-static)
(delete 'install-user-static))))) (delete 'install-user-static)))))
;; Remove dependencies on optional libraries, notably GUI libraries. ;; Remove dependencies on optional libraries, notably GUI libraries.
(native-inputs (filter (lambda (input) (native-inputs (filter (lambda (input)