Re: [PATCH] syscalls: Turn syscalls wrappers into procedures.

[Mark H Weaver]

Manolis Ragkousis <address@hidden> writes:

> From c2800b786f62c190b35e306e59af7a73a19094e0 Mon Sep 17 00:00:00 2001
> From: Manolis Ragkousis <address@hidden>
> Date: Fri, 21 Aug 2015 22:00:16 +0300
> Subject: [PATCH] syscalls: Turn syscalls wrappers into procedures.
>
> * guix/build/syscalls.scm (mount, umount, swapon, swapoff,
>   setns, pivot-root, clone): Turn into procedures.

This commit would change the API of (guix build syscalls), without
updating any of the code that uses that API.  This would break
everything that uses this API.

Anyway, the bindings you changed are already procedures.  You could
accomplish the same thing you're doing now without changing the API,
by simply moving the 'lambda*' outside of the 'let*', like this:

--8<---------------cut here---------------start------------->8---
(define mount
  (lambda* (source target type #:optional (flags 0) options
                   #:key (update-mtab? #f))
    "Mount device SOURCE on TARGET as a file system TYPE.  Optionally, FLAGS
may be a bitwise-or of the MS_* <sys/mount.h> constants, and OPTIONS may be a
string.  When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored.  When
UPDATE-MTAB? is true, update /etc/mtab.  Raise a 'system-error' exception on
error."
    (let* ((ptr  (dynamic-func "mount" (dynamic-link)))
           (proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
      (let ((ret (proc (if source
                           (string->pointer source)
                           %null-pointer)
[...]
--8<---------------cut here---------------end--------------->8---

However, this approach will be quite inefficient, whether done as shown
above or using your patch, because the FFI wrappers will be newly
created each time these procedures are called, and then thrown away.

Instead, I would prefer to gracefully handle the case where these
syscalls are not available.  In that case, we can bind the variable to a
procedure that reports the error when it's called.

I've attached an (untested) patch that does this.  Can you see if it
works for you?

     Thanks!
       Mark

>From b283ad4097a48de11a616083da09ae0e76bab343 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Sat, 22 Aug 2015 13:07:50 -0400
Subject: [PATCH] syscalls: If a syscall is not available, defer the error.

* guix/build/syscalls.scm (syscall->procedure): New procedure.
  (mount, umount, swapon, swapoff, clone, setns, pivot-root): Use it.
---
 guix/build/syscalls.scm | 35 +++++++++++++++++++++--------------
 1 file changed, 21 insertions(+), 14 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 68f340c..3065f43 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 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.
 ;;;
@@ -135,6 +136,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")))
@@ -183,8 +197,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
@@ -212,8 +225,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_*
@@ -240,8 +252,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))
@@ -252,8 +263,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)))
@@ -313,8 +323,7 @@ string TMPL and return its file name.  TMPL must end with 
'XXXXXX'."
 ;; The libc interface to sys_clone is not useful for Scheme programs, so the
 ;; low-level system call is wrapped instead.
 (define clone
-  (let* ((ptr        (dynamic-func "syscall" (dynamic-link)))
-         (proc       (pointer->procedure int ptr (list int int '*)))
+  (let ((proc (syscall->procedure int "syscall" (list int int '*)))
          ;; TODO: Don't do this.
          (syscall-id (match (utsname:machine (uname))
                        ("i686"   120)
@@ -328,8 +337,7 @@ are shared between the parent and child processes."
       (proc syscall-id flags %null-pointer))))
 
 (define setns
-  (let* ((ptr  (dynamic-func "setns" (dynamic-link)))
-         (proc (pointer->procedure int ptr (list int int))))
+  (let ((proc (syscall->procedure int "setns" (list int int))))
     (lambda (fdes nstype)
       "Reassociate the current process with the namespace specified by FDES, a
 file descriptor obtained by opening a /proc/PID/ns/* file.  NSTYPE specifies
@@ -343,8 +351,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."
-- 
2.5.0