diff options
author | Mark H Weaver <mhw@netris.org> | 2016-02-10 14:17:33 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2016-04-18 19:36:31 +0200 |
commit | 4f8cede062cf89a8326842c6a60e8e0178a78b2c (patch) | |
tree | e499d64aa5d25c7b7b4f53948f6ac6c61e583df6 | |
parent | dd1d09f7e4c522d2185eda9c806ea525e10172be (diff) | |
download | guix-patches-4f8cede062cf89a8326842c6a60e8e0178a78b2c.tar guix-patches-4f8cede062cf89a8326842c6a60e8e0178a78b2c.tar.gz |
syscalls: If a syscall is not available, defer the error.
* guix/build/syscalls.scm (syscall->procedure): New procedure.
(mount, umount, swapon, swapoff, clone, pivot-root): Use it.
(clone): Add case for nonexistent syscall id.
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
-rw-r--r-- | guix/build/syscalls.scm | 43 |
1 files changed, 26 insertions, 17 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 5ce0abbb48..04fc3ef5fe 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -145,6 +146,19 @@ "Evaluate EXPR and restart upon EINTR. Return the value of EXPR." (call-with-restart-on-EINTR (lambda () expr))) +(define (syscall->procedure return-type name argument-types) + "Return a procedure that wraps the C function NAME using the dynamic FFI. +If an error occurs while creating the binding, defer the error report until +the returned procedure is called." + (catch #t + (lambda () + (let ((ptr (dynamic-func name (dynamic-link)))) + (pointer->procedure return-type ptr argument-types))) + (lambda args + (lambda _ + (error (format #f "~a: syscall->procedure failed: ~s" + name args)))))) + (define (augment-mtab source target type options) "Augment /etc/mtab with information about the given mount point." (let ((port (open-file "/etc/mtab" "a"))) @@ -193,8 +207,7 @@ (define UMOUNT_NOFOLLOW 8) (define mount - (let* ((ptr (dynamic-func "mount" (dynamic-link))) - (proc (pointer->procedure int ptr `(* * * ,unsigned-long *)))) + (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *)))) (lambda* (source target type #:optional (flags 0) options #:key (update-mtab? #f)) "Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS @@ -222,8 +235,7 @@ error." (augment-mtab source target type options)))))) (define umount - (let* ((ptr (dynamic-func "umount2" (dynamic-link))) - (proc (pointer->procedure int ptr `(* ,int)))) + (let ((proc (syscall->procedure int "umount2" `(* ,int)))) (lambda* (target #:optional (flags 0) #:key (update-mtab? #f)) "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* @@ -250,8 +262,7 @@ constants from <sys/mount.h>." (loop (cons mount-point result)))))))))) (define swapon - (let* ((ptr (dynamic-func "swapon" (dynamic-link))) - (proc (pointer->procedure int ptr (list '* int)))) + (let ((proc (syscall->procedure int "swapon" (list '* int)))) (lambda* (device #:optional (flags 0)) "Use the block special device at DEVICE for swapping." (let ((ret (proc (string->pointer device) flags)) @@ -262,8 +273,7 @@ constants from <sys/mount.h>." (list err))))))) (define swapoff - (let* ((ptr (dynamic-func "swapoff" (dynamic-link))) - (proc (pointer->procedure int ptr '(*)))) + (let ((proc (syscall->procedure int "swapoff" '(*)))) (lambda (device) "Stop using block special device DEVICE for swapping." (let ((ret (proc (string->pointer device))) @@ -327,18 +337,18 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." ;; declared in <unistd.h> as a variadic function; in practice, it expects 6 ;; pointer-sized arguments, as shown in, e.g., x86_64/syscall.S. (define clone - (let* ((ptr (dynamic-func "syscall" (dynamic-link))) - (proc (pointer->procedure long ptr - (list long ;sysno - unsigned-long ;flags - '* '* '* - '*))) + (let* ((proc (syscall->procedure int "syscall" + (list long ;sysno + unsigned-long ;flags + '* '* '* + '*))) ;; TODO: Don't do this. (syscall-id (match (utsname:machine (uname)) ("i686" 120) ("x86_64" 56) ("mips64" 5055) - ("armv7l" 120)))) + ("armv7l" 120) + (_ #f)))) (lambda (flags) "Create a new child process by duplicating the current parent process. Unlike the fork system call, clone accepts FLAGS that specify which resources @@ -373,8 +383,7 @@ there is no such limitation." (list err)))))))) (define pivot-root - (let* ((ptr (dynamic-func "pivot_root" (dynamic-link))) - (proc (pointer->procedure int ptr (list '* '*)))) + (let ((proc (syscall->procedure int "pivot_root" (list '* '*)))) (lambda (new-root put-old) "Change the root file system to NEW-ROOT and move the current root file system to PUT-OLD." |