[PATCH] syscalls: Turn syscalls wrappers into procedures.

[PATCH] syscalls: Turn syscalls wrappers into procedures.

[Manolis Ragkousis]

[-- Attachment #1: Type: text/plain, Size: 265 bytes --]

In hurd there are some syscalls that are not available. By turning
those scheme wrappers in procedures we can just delegate their
evaluation till they are actually needed, thus bypassing the need for
them to actually exist for now and enable guix to build on Hurd.

[-- Attachment #2: 0001-syscalls-Turn-syscalls-wrappers-into-procedures.patch --]
[-- Type: text/x-patch, Size: 3262 bytes --]

From 1dbdd1f9908799ebc32854e91619cfaae96b4dc4 Mon Sep 17 00:00:00 2001
From: Manolis Ragkousis <manolis837@gmail.com>
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.
---
 guix/build/syscalls.scm | 17 ++++++++++-------
 1 file changed, 10 insertions(+), 7 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index fc801a5..44f9f4e 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -182,7 +182,7 @@
 (define MNT_EXPIRE      4)
 (define UMOUNT_NOFOLLOW 8)
 
-(define mount
+(define (mount)
   (let* ((ptr  (dynamic-func "mount" (dynamic-link)))
          (proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
     (lambda* (source target type #:optional (flags 0) options
@@ -211,7 +211,7 @@ error."
         (when update-mtab?
           (augment-mtab source target type options))))))
 
-(define umount
+(define (umount)
   (let* ((ptr  (dynamic-func "umount2" (dynamic-link)))
          (proc (pointer->procedure int ptr `(* ,int))))
     (lambda* (target #:optional (flags 0)
@@ -239,7 +239,7 @@ constants from <sys/mount.h>."
                 ((source mount-point _ ...)
                  (loop (cons mount-point result))))))))))
 
-(define swapon
+(define (swapon)
   (let* ((ptr  (dynamic-func "swapon" (dynamic-link)))
          (proc (pointer->procedure int ptr (list '* int))))
     (lambda* (device #:optional (flags 0))
@@ -251,7 +251,7 @@ constants from <sys/mount.h>."
                  (list device (strerror err))
                  (list err)))))))
 
-(define swapoff
+(define (swapoff)
   (let* ((ptr  (dynamic-func "swapoff" (dynamic-link)))
          (proc (pointer->procedure int ptr '(*))))
     (lambda (device)
@@ -310,9 +310,12 @@ string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
 (define CLONE_NEWPID  #x20000000)
 (define CLONE_NEWNET  #x40000000)
 
+;; By turning the syscalls wrappers into procedures we can delegate their evaluation
+;; till they are actually needed, thus enabling Guix to build on systems which the
+;; syscalls are not available. 
 ;; The libc interface to sys_clone is not useful for Scheme programs, so the
 ;; low-level system call is wrapped instead.
-(define clone
+(define (clone)
   (let* ((ptr        (dynamic-func "syscall" (dynamic-link)))
          (proc       (pointer->procedure int ptr (list int int '*)))
          ;; TODO: Don't do this.
@@ -327,7 +330,7 @@ Unlike the fork system call, clone accepts FLAGS that specify which resources
 are shared between the parent and child processes."
       (proc syscall-id flags %null-pointer))))
 
-(define setns
+(define (setns)
   ;; Some systems may be using an old (pre-2.14) version of glibc where there
   ;; is no 'setns' function available.
   (false-if-exception
@@ -345,7 +348,7 @@ there is no such limitation."
                   (list fdes nstype (strerror err))
                   (list err))))))))
 
-(define pivot-root
+(define (pivot-root)
   (let* ((ptr  (dynamic-func "pivot_root" (dynamic-link)))
          (proc (pointer->procedure int ptr (list '* '*))))
     (lambda (new-root put-old)
-- 
2.5.0

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

[Manolis Ragkousis]

[-- Attachment #1: Type: text/plain, Size: 29 bytes --]

Resending the correct patch.

[-- Attachment #2: 0001-syscalls-Turn-syscalls-wrappers-into-procedures.patch --]
[-- Type: text/x-patch, Size: 3192 bytes --]

From c2800b786f62c190b35e306e59af7a73a19094e0 Mon Sep 17 00:00:00 2001
From: Manolis Ragkousis <manolis837@gmail.com>
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.
---
 guix/build/syscalls.scm | 17 ++++++++++-------
 1 file changed, 10 insertions(+), 7 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index fc801a5..c65456f 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -182,7 +182,10 @@
 (define MNT_EXPIRE      4)
 (define UMOUNT_NOFOLLOW 8)
 
-(define mount
+;; By turning the syscalls wrappers into procedures we can delegate their evaluation
+;; till they are actually needed, thus enabling Guix to build on systems which the
+;; syscalls are not available. 
+(define (mount)
   (let* ((ptr  (dynamic-func "mount" (dynamic-link)))
          (proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
     (lambda* (source target type #:optional (flags 0) options
@@ -211,7 +214,7 @@ error."
         (when update-mtab?
           (augment-mtab source target type options))))))
 
-(define umount
+(define (umount)
   (let* ((ptr  (dynamic-func "umount2" (dynamic-link)))
          (proc (pointer->procedure int ptr `(* ,int))))
     (lambda* (target #:optional (flags 0)
@@ -239,7 +242,7 @@ constants from <sys/mount.h>."
                 ((source mount-point _ ...)
                  (loop (cons mount-point result))))))))))
 
-(define swapon
+(define (swapon)
   (let* ((ptr  (dynamic-func "swapon" (dynamic-link)))
          (proc (pointer->procedure int ptr (list '* int))))
     (lambda* (device #:optional (flags 0))
@@ -251,7 +254,7 @@ constants from <sys/mount.h>."
                  (list device (strerror err))
                  (list err)))))))
 
-(define swapoff
+(define (swapoff)
   (let* ((ptr  (dynamic-func "swapoff" (dynamic-link)))
          (proc (pointer->procedure int ptr '(*))))
     (lambda (device)
@@ -312,7 +315,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
+(define (clone)
   (let* ((ptr        (dynamic-func "syscall" (dynamic-link)))
          (proc       (pointer->procedure int ptr (list int int '*)))
          ;; TODO: Don't do this.
@@ -327,7 +330,7 @@ Unlike the fork system call, clone accepts FLAGS that specify which resources
 are shared between the parent and child processes."
       (proc syscall-id flags %null-pointer))))
 
-(define setns
+(define (setns)
   ;; Some systems may be using an old (pre-2.14) version of glibc where there
   ;; is no 'setns' function available.
   (false-if-exception
@@ -345,7 +348,7 @@ there is no such limitation."
                   (list fdes nstype (strerror err))
                   (list err))))))))
 
-(define pivot-root
+(define (pivot-root)
   (let* ((ptr  (dynamic-func "pivot_root" (dynamic-link)))
          (proc (pointer->procedure int ptr (list '* '*))))
     (lambda (new-root put-old)
-- 
2.5.0

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

[Mark H Weaver]

[-- Attachment #1: Type: text/plain, Size: 2104 bytes --]

Manolis Ragkousis <manolis837@gmail.com> writes:

> From c2800b786f62c190b35e306e59af7a73a19094e0 Mon Sep 17 00:00:00 2001
> From: Manolis Ragkousis <manolis837@gmail.com>
> 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


[-- Attachment #2: [PATCH] syscalls: If a syscall is not available, defer the error --]
[-- Type: text/x-patch, Size: 5166 bytes --]

From b283ad4097a48de11a616083da09ae0e76bab343 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
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 <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.
 ;;;
@@ -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

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

[Ludovic Courtès]

[-- Attachment #1: Type: text/plain, Size: 536 bytes --]

Manolis Ragkousis <manolis837@gmail.com> skribis:

> In hurd there are some syscalls that are not available. By turning
> those scheme wrappers in procedures we can just delegate their
> evaluation till they are actually needed, thus bypassing the need for
> them to actually exist for now and enable guix to build on Hurd.

(Sorry again for the delay.)

As I wrote elsewhere, I’d prefer to simply omit compilation of this file
on GNU/Hurd.  If that’s fine with you, I’ll commit the patch below.

Thanks,
Ludo’.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 2075 bytes --]

diff --git a/Makefile.am b/Makefile.am
index ada4cbe..4a3a2d8 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -88,7 +88,6 @@ MODULES =					\
   guix/build/rpath.scm				\
   guix/build/cvs.scm				\
   guix/build/svn.scm				\
-  guix/build/syscalls.scm			\
   guix/build/gremlin.scm			\
   guix/build/emacs-utils.scm			\
   guix/build/graft.scm				\
@@ -124,6 +123,13 @@ MODULES =					\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
 
+if BUILD_SYSCALLS_MODULE
+
+MODULES +=					\
+  guix/build/syscalls.scm			\
+
+endif
+
 if BUILD_DAEMON_OFFLOAD
 
 MODULES +=					\
@@ -298,6 +304,12 @@ EXTRA_DIST +=					\
 
 endif !BUILD_DAEMON_OFFLOAD
 
+if !BUILD_SYSCALLS_MODULE
+
+EXTRA_DIST += guix/build/syscalls.scm
+
+endif !BUILD_SYSCALLS_MODULE
+
 
 CLEANFILES =					\
   $(GOBJECTS)					\
diff --git a/configure.ac b/configure.ac
index 2c8b9f0..247a9d5 100644
--- a/configure.ac
+++ b/configure.ac
@@ -85,6 +85,11 @@ dnl Check whether (srfi srfi-37) works, and provide our own if it doesn't.
 GUIX_CHECK_SRFI_37
 AM_CONDITIONAL([INSTALL_SRFI_37], [test "x$ac_cv_guix_srfi_37_broken" = xyes])
 
+dnl Check whether (guix build syscalls) can be built.
+GUIX_CHECK_LIBC_MOUNT
+AM_CONDITIONAL([BUILD_SYSCALLS_MODULE],
+  [test "x$guix_cv_libc_has_mount" = "xyes"])
+
 AC_ARG_WITH([nix-prefix],
   [AS_HELP_STRING([--with-nix-prefix=DIR],
     [search for Nix in DIR (for testing purposes and '--disable-daemon' builds)])],
diff --git a/m4/guix.m4 b/m4/guix.m4
index fa5a402..2113383 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -257,3 +257,16 @@ AC_DEFUN([GUIX_ASSERT_CXX11], [
     AC_MSG_ERROR([C++ compiler '$CXX' does not support the C++11 standard])
   fi
 ])
+
+dnl GUIX_CHECK_LIBC_MOUNT
+dnl
+dnl Check whether libc provides 'mount'.  On GNU/Hurd it doesn't (yet).
+AC_DEFUN([GUIX_CHECK_LIBC_MOUNT], [
+  AC_CACHE_CHECK([whether libc provides 'mount'], [guix_cv_libc_has_mount],
+    [GUILE_CHECK([retval], [(dynamic-func \"mount\" (dynamic-link))])
+     if test "$retval" = 0; then
+       guix_cv_libc_has_mount="yes"
+     else
+       guix_cv_libc_has_mount="no"
+     fi])
+])

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

[Ludovic Courtès]

ludo@gnu.org (Ludovic Courtès) skribis:

> As I wrote elsewhere, I’d prefer to simply omit compilation of this file
> on GNU/Hurd.  If that’s fine with you, I’ll commit the patch below.

Done in 12e5b26.

Ludo’.

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

[Manolis Ragkousis]

Sorry Ludo, I somehow missed this mail.

I am totally fine with it, thank you!!

Manolis