[PATCH] build: syscalls: Delay syscalls evaluation.

[PATCH] build: syscalls: Delay syscalls evaluation.

[Manolis Ragkousis]

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

Hello hackers,

Justus tried to build Guix on his Hurd machine and he found out that
even though we disable (guix build syscalls) from building when
sys/mount.h is not present, it still tries to build it.

As I found out, (guix utils) module uses the syscalls module so that's
why it still tried to build it. That's why I followed a different approach.
I delayed the evaluation of ptr and proc on mount, umount, swapon, etc.
and it builds now.

WDYT? If you agree with the change I will push it to wip-hurd and/or
master.

Manolis

[-- Attachment #2: 0001-build-syscalls-Delay-syscalls-evaluation.patch --]
[-- Type: text/x-patch, Size: 6929 bytes --]

From 0e05ab007e312800d22949543e935d9b91093aee Mon Sep 17 00:00:00 2001
From: Manolis Ragkousis <manolis837@gmail.com>
Date: Fri, 5 Feb 2016 14:22:20 +0200
Subject: [PATCH] build: syscalls: Delay syscalls evaluation.

* guix/build/syscalls.scm (mount, umount, swapon,
  swapoff, clone, pivot-root): Delay syscalls evaluation.
---
 guix/build/syscalls.scm | 66 ++++++++++++++++++++++++++-----------------------
 1 file changed, 35 insertions(+), 31 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index ea68b22..60e6f50 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -22,6 +22,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-45)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
@@ -184,9 +185,11 @@
 (define MNT_EXPIRE      4)
 (define UMOUNT_NOFOLLOW 8)
 
+;; Delay syscalls evaluation so we can workaround the fact that they do not
+;; exist on GNU Hurd.
 (define mount
-  (let* ((ptr  (dynamic-func "mount" (dynamic-link)))
-         (proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
+  (let* ((ptr  (delay (dynamic-func "mount" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) `(* * * ,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
@@ -194,17 +197,18 @@ 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 ((ret (proc (if source
-                           (string->pointer source)
-                           %null-pointer)
-                       (string->pointer target)
-                       (if type
-                           (string->pointer type)
-                           %null-pointer)
-                       flags
-                       (if options
-                           (string->pointer options)
-                           %null-pointer)))
+      (let ((ret ((force proc)
+                  (if source
+                      (string->pointer source)
+                      %null-pointer)
+                  (string->pointer target)
+                  (if type
+                      (string->pointer type)
+                      %null-pointer)
+                  flags
+                  (if options
+                      (string->pointer options)
+                      %null-pointer)))
             (err (errno)))
         (unless (zero? ret)
           (throw 'system-error "mount" "mount ~S on ~S: ~A"
@@ -214,13 +218,13 @@ error."
           (augment-mtab source target type options))))))
 
 (define umount
-  (let* ((ptr  (dynamic-func "umount2" (dynamic-link)))
-         (proc (pointer->procedure int ptr `(* ,int))))
+  (let* ((ptr  (delay (dynamic-func "umount2" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) `(* ,int)))))
     (lambda* (target #:optional (flags 0)
                      #:key (update-mtab? #f))
       "Unmount TARGET.  Optionally FLAGS may be one of the MNT_* or UMOUNT_*
 constants from <sys/mount.h>."
-      (let ((ret (proc (string->pointer target) flags))
+      (let ((ret ((force proc) (string->pointer target) flags))
             (err (errno)))
         (unless (zero? ret)
           (throw 'system-error "umount" "~S: ~A"
@@ -242,11 +246,11 @@ 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* ((ptr  (delay (dynamic-func "swapon" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) (list '* int)))))
     (lambda* (device #:optional (flags 0))
       "Use the block special device at DEVICE for swapping."
-      (let ((ret (proc (string->pointer device) flags))
+      (let ((ret ((force proc) (string->pointer device) flags))
             (err (errno)))
         (unless (zero? ret)
           (throw 'system-error "swapon" "~S: ~A"
@@ -254,11 +258,11 @@ constants from <sys/mount.h>."
                  (list err)))))))
 
 (define swapoff
-  (let* ((ptr  (dynamic-func "swapoff" (dynamic-link)))
-         (proc (pointer->procedure int ptr '(*))))
+  (let* ((ptr  (delay (dynamic-func "swapoff" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) '(*)))))
     (lambda (device)
       "Stop using block special device DEVICE for swapping."
-      (let ((ret (proc (string->pointer device)))
+      (let ((ret ((force proc) (string->pointer device)))
             (err (errno)))
         (unless (zero? ret)
           (throw 'system-error "swapoff" "~S: ~A"
@@ -326,16 +330,16 @@ string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
                                                '* '* '*
                                                '*)))
          ;; TODO: Don't do this.
-         (syscall-id (match (utsname:machine (uname))
-                       ("i686"   120)
-                       ("x86_64" 56)
-                       ("mips64" 5055)
-                       ("armv7l" 120))))
+         (syscall-id (delay (match (utsname:machine (uname))
+                              ("i686"   120)
+                              ("x86_64" 56)
+                              ("mips64" 5055)
+                              ("armv7l" 120)))))
     (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
 are shared between the parent and child processes."
-      (let ((ret (proc syscall-id flags
+      (let ((ret (proc (force syscall-id) flags
                        %null-pointer               ;child stack
                        %null-pointer %null-pointer ;ptid & ctid
                        %null-pointer))             ;unused
@@ -365,12 +369,12 @@ 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* ((ptr  (delay (dynamic-func "pivot_root" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) (list '* '*)))))
     (lambda (new-root put-old)
       "Change the root file system to NEW-ROOT and move the current root file
 system to PUT-OLD."
-      (let ((ret (proc (string->pointer new-root)
+      (let ((ret ((force proc) (string->pointer new-root)
                        (string->pointer put-old)))
             (err (errno)))
         (unless (zero? ret)
-- 
2.6.4

Re: [PATCH] build: syscalls: Delay syscalls evaluation.

[Mark H Weaver]

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

Manolis Ragkousis <manolis837@gmail.com> writes:

> Hello hackers,
>
> Justus tried to build Guix on his Hurd machine and he found out that
> even though we disable (guix build syscalls) from building when
> sys/mount.h is not present, it still tries to build it.
>
> As I found out, (guix utils) module uses the syscalls module so that's
> why it still tried to build it. That's why I followed a different approach.
> I delayed the evaluation of ptr and proc on mount, umount, swapon, etc.
> and it builds now.
>
> WDYT? If you agree with the change I will push it to wip-hurd and/or
> master.

The last time this issue was raised, in August 2015, I came up with
another approach to accomplish the same goal, but without any per-call
overhead.  I vaguely recall proposing it, but I don't remember where or
what came of it.  I've attached it below.

      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] build: syscalls: Delay syscalls evaluation.

[Ludovic Courtès]

Mark H Weaver <mhw@netris.org> skribis:

> 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.

Even better, indeed.

[...]

> +(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."

Maybe add this is for GNU/Hurd, which lacks some of these wrappers.

Otherwise OK, please push!

Thanks to the two of you,
Ludo’.

Re: [PATCH] build: syscalls: Delay syscalls evaluation.

[Manolis Ragkousis]

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

Hey hackers,

I modified the patch to apply to wip-hurd and I removed the setns part
because it was already handled (commit 39e336b5c83e) and Ludo told me
not to change it.

I also added a case for nonexistent clone syscall id. If I don't, clone
will fail with "case not found for i686-AT386" which is the case for Hurd.

Mark, Ludo if you agree with the changes I will push it. :-)

Manolis


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-syscalls-If-a-syscall-is-not-available-defer-the-err.patch --]
[-- Type: text/x-patch; name="0001-syscalls-If-a-syscall-is-not-available-defer-the-err.patch", Size: 5461 bytes --]

From 761d4b04701b62042fba810b04da82ca2200b862 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 10 Feb 2016 14:17:33 +0200
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, pivot-root): Use it.
  (clone): Add case for nonexistent syscall id.
---
 guix/build/syscalls.scm | 43 ++++++++++++++++++++++++++-----------------
 1 file changed, 26 insertions(+), 17 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index a3b68c4..247e64f 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.
 ;;;
@@ -137,6 +138,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")))
@@ -185,8 +199,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
@@ -214,8 +227,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_*
@@ -242,8 +254,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))
@@ -254,8 +265,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)))
@@ -319,18 +329,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
@@ -365,8 +375,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.7.1

Re: [PATCH] build: syscalls: Delay syscalls evaluation.

[Ludovic Courtès]

Manolis Ragkousis <manolis837@gmail.com> skribis:

> From 761d4b04701b62042fba810b04da82ca2200b862 Mon Sep 17 00:00:00 2001
> From: Mark H Weaver <mhw@netris.org>
> Date: Wed, 10 Feb 2016 14:17:33 +0200
> 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, pivot-root): Use it.
>   (clone): Add case for nonexistent syscall id.

I’ve finally applied it.  Sorry that it took no less than two months for
something everyone had agreed on!

Ludo’.