02/02: syscalls: If a syscall is not available, defer the error.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 4f8cede062cf89a8326842c6a60e8e0178a78b2c
Author: Mark H Weaver <address@hidden>
Date:   Wed Feb 10 14:17:33 2016 +0200

    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 <address@hidden>
---
 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 5ce0abb..04fc3ef 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 <address@hidden>
 ;;; Copyright © 2015 David Thompson <address@hidden>
+;;; Copyright © 2015 Mark H Weaver <address@hidden>
 ;;;
 ;;; 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."