bug#26341: [PATCH] build: vm: Add missing module.

bug#26341: [PATCH] build: vm: Add missing module.

[Mathieu Othacehe]

* gnu/build/vm.scm (define-module): Use module (guix build syscalls).

It fixes the following warnings during guix build :

gnu/build/vm.scm:233:3: warning: possibly unbound variable `mount'
gnu/build/vm.scm:238:3: warning: possibly unbound variable `umount'
gnu/build/vm.scm:268:8: warning: possibly unbound variable `mount'
gnu/build/vm.scm:276:8: warning: possibly unbound variable `umount'
gnu/build/vm.scm:315:4: warning: possibly unbound variable `mount'
gnu/build/vm.scm:323:4: warning: possibly unbound variable `umount'
---
 gnu/build/vm.scm | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 766163e1d..cc705832c 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -22,6 +22,7 @@
 (define-module (gnu build vm)
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
+  #:use-module (guix build syscalls)
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
   #:use-module (guix records)
-- 
2.12.2

bug#26341: [PATCH] build: vm: Add missing module.

[Ludovic Courtès]

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

Hello Mathieu,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> * gnu/build/vm.scm (define-module): Use module (guix build syscalls).
>
> It fixes the following warnings during guix build :
>
> gnu/build/vm.scm:233:3: warning: possibly unbound variable `mount'
> gnu/build/vm.scm:238:3: warning: possibly unbound variable `umount'
> gnu/build/vm.scm:268:8: warning: possibly unbound variable `mount'
> gnu/build/vm.scm:276:8: warning: possibly unbound variable `umount'
> gnu/build/vm.scm:315:4: warning: possibly unbound variable `mount'
> gnu/build/vm.scm:323:4: warning: possibly unbound variable `umount'

This is weird but on purpose: this module is used in a context, in (gnu
system vm), where ‘guile-static-stripped’ is running, in the initrd.
And ‘guile-static-stripped’ has ‘guile-linux-syscalls.patch’, which adds
bindings for ‘mount’, ‘umount’, etc.

Conversely, (guix build syscalls) relies on the ability to do
dlopen(NULL) and to resolve “mount” et al. from libc.so.  This cannot
work with the statically-linked Guile, which is why we have
‘guile-linux-syscalls.patch’.

So this patch cannot be applied as is, and I think it would break things
that use (gnu build vm).

That said, we should improve this.  Perhaps something along the lines of
the attached patch would work.

Could you try and send an updated patch?

Thanks,
Ludo’.


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

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 5aae1530f..e108d6169 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -462,7 +462,9 @@ the returned procedure is called."
 (define UMOUNT_NOFOLLOW 8)
 
 (define mount
-  (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
+  (let ((proc (if (module-defined? the-scm-module 'mount)
+                  (module-ref the-scm-module 'mount)
+                  (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

bug#26341: [PATCH] build: vm: Add missing module.

[Mathieu Othacehe]

Hi Ludo,

> That said, we should improve this.  Perhaps something along the lines of
> the attached patch would work.
>
> Could you try and send an updated patch?

Well, I tried a "guix system vm ..." with just my patch and it worked. I
agree with you it shouldn't work because it is not possible to use FFI
in static Guile.

I don't exactly what happend but it might be something like that :

(gnu build vm) -- uses module ----> (guix build syscalls) (with my patch)
                      |                    |
                      |                    |
                      |               -------- provides
                      |               |      |
                      |               v      v
                      |               mount  umount (FFI versions)
                      |
                      -------------> (gnu build linux-boot)
                                          |
                                          | uses
                                       (gnu build file-systems)
                                                  |
                                                  |
                                                  overrides mount and
                                                  unount with libguile
                                                  versions if you're
                                                  using static Guile.

So we end-up using libguile mount and umount in (gnu build vm) and not
FFI versions of (guix build syscalls).

However, it is still a good idea to allow modules to use (guix build
syscalls) independently of the fact that they are running inside static
Guile or not.

So the attached patch (your previous patch, sligtly modified) could be
ok ?

Thank you,

Mathieu

                                                 
                                                  
                                                  
                                                  

bug#26341: [PATCH] build: vm: Add missing module.

[Mathieu Othacehe]

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


The attached patch ...

Sorry

Mathie

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

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 3fa318df3..2de664aa7 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -462,51 +462,51 @@ the returned procedure is called."
 (define UMOUNT_NOFOLLOW 8)
 
 (define mount
-  (let ((proc (if (module-defined? the-scm-module 'mount)
-                  (module-ref the-scm-module 'mount)
-                  (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
+  (if (module-defined? the-scm-module 'mount)
+      (module-ref the-scm-module 'mount)
+      (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
 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-values (((ret err)
-                    (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))))
-        (unless (zero? ret)
-          (throw 'system-error "mount" "mount ~S on ~S: ~A"
-                 (list source target (strerror err))
-                 (list err)))
-        (when update-mtab?
-          (augment-mtab source target type options))))))
+          (let-values (((ret err)
+                        (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))))
+            (unless (zero? ret)
+              (throw 'system-error "mount" "mount ~S on ~S: ~A"
+                     (list source target (strerror err))
+                     (list err)))
+            (when update-mtab?
+              (augment-mtab source target type options)))))))
 
 (define umount
-  (let ((proc (if (module-defined? the-scm-module 'umount)
-                  (module-ref the-scm-module 'umount)
-                  (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_*
+  (if (module-defined? the-scm-module 'umount)
+      (module-ref the-scm-module 'umount)
+      (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_*
 constants from <sys/mount.h>."
-      (let-values (((ret err)
-                    (proc (string->pointer target) flags)))
-        (unless (zero? ret)
-          (throw 'system-error "umount" "~S: ~A"
-                 (list target (strerror err))
-                 (list err)))
-        (when update-mtab?
-          (remove-from-mtab target))))))
+          (let-values (((ret err)
+                        (proc (string->pointer target) flags)))
+            (unless (zero? ret)
+              (throw 'system-error "umount" "~S: ~A"
+                     (list target (strerror err))
+                     (list err)))
+            (when update-mtab?
+              (remove-from-mtab target)))))))
 
 (define (mount-points)
   "Return the mounts points for currently mounted file systems."

[-- Attachment #3: Type: text/plain, Size: 2 bytes --]

u

bug#26341: [PATCH] build: vm: Add missing module.

[Ludovic Courtès]

Hello!

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

>> That said, we should improve this.  Perhaps something along the lines of
>> the attached patch would work.
>>
>> Could you try and send an updated patch?
>
> Well, I tried a "guix system vm ..." with just my patch and it worked. I
> agree with you it shouldn't work because it is not possible to use FFI
> in static Guile.
>
> I don't exactly what happend but it might be something like that :
>
> (gnu build vm) -- uses module ----> (guix build syscalls) (with my patch)
>                       |                    |
>                       |                    |
>                       |               -------- provides
>                       |               |      |
>                       |               v      v
>                       |               mount  umount (FFI versions)
>                       |
>                       -------------> (gnu build linux-boot)
>                                           |
>                                           | uses
>                                        (gnu build file-systems)
>                                                   |
>                                                   |
>                                                   overrides mount and
>                                                   unount with libguile
>                                                   versions if you're
>                                                   using static Guile.
>
> So we end-up using libguile mount and umount in (gnu build vm) and not
> FFI versions of (guix build syscalls).

Yeah, I think there must have been a “(guix build syscalls) overrides
core binding ‘mount’” warning, and Guile chose the core binding over the
other one so things turned out to work fine.

> However, it is still a good idea to allow modules to use (guix build
> syscalls) independently of the fact that they are running inside static
> Guile or not.

Agreed!

Ludo’.

bug#26341: [PATCH] build: vm: Add missing module.

[Ludovic Courtès]

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
> index 3fa318df3..2de664aa7 100644
> --- a/guix/build/syscalls.scm
> +++ b/guix/build/syscalls.scm
> @@ -462,51 +462,51 @@ the returned procedure is called."
>  (define UMOUNT_NOFOLLOW 8)
>  
>  (define mount
> -  (let ((proc (if (module-defined? the-scm-module 'mount)
> -                  (module-ref the-scm-module 'mount)
> -                  (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
> +  (if (module-defined? the-scm-module 'mount)
> +      (module-ref the-scm-module 'mount)
> +      (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
>  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."

That introduces a slight difference: in one case #:update-mtab? is not
honored.  That said, it’s probably OK to ignore it; maybe leave an “XXX”
comment above just in case.  ;-)

Otherwise LGTM.

Can you send a ‘git format-patch’ thing?  (Otherwise I could write the
commit log on your behalf.)

Thanks!

Ludo’.

bug#26341: [PATCH] build: vm: Add missing module.

[Mathieu Othacehe]

> That introduces a slight difference: in one case #:update-mtab? is not
> honored.  That said, it’s probably OK to ignore it; maybe leave an “XXX”
> comment above just in case.  ;-)

Ok !

> Can you send a ‘git format-patch’ thing?  (Otherwise I could write the
> commit log on your behalf.)

Sure, I'll send new patches !

I have a follow-up question. Would it be ok to do the same thing for
other warnings on syscalls, 'reboot' for example ?

Thanks,

Mathieu

bug#26341: [PATCH 1/2] build: syscalls: Allow mount and umount use from static Guile.

[Mathieu Othacehe]

* guix/build/syscalls.scm (mount): Use Guile core mount if called from
  static Guile, otherwise use FFI based mount implementation.
  (umount): Ditto.
  This allows to use (guix build syscalls) from a module independently
  of calling context.
---
 guix/build/syscalls.scm | 86 +++++++++++++++++++++++++++----------------------
 1 file changed, 48 insertions(+), 38 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 5aae1530f..4bcb2a871 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -462,47 +462,57 @@ the returned procedure is called."
 (define UMOUNT_NOFOLLOW 8)
 
 (define mount
-  (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
-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-values (((ret err)
-                    (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))))
-        (unless (zero? ret)
-          (throw 'system-error "mount" "mount ~S on ~S: ~A"
-                 (list source target (strerror err))
-                 (list err)))
-        (when update-mtab?
-          (augment-mtab source target type options))))))
+  ;; If called from the statically linked Guile, use Guile core 'mount'.
+  ;; Otherwise, use an FFI binding to define 'mount'.
+  ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
+  (if (module-defined? the-scm-module 'mount)
+      (module-ref the-scm-module 'mount)
+      (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 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-values (((ret err)
+                        (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))))
+            (unless (zero? ret)
+              (throw 'system-error "mount" "mount ~S on ~S: ~A"
+                     (list source target (strerror err))
+                     (list err)))
+            (when update-mtab?
+              (augment-mtab source target type options)))))))
 
 (define umount
-  (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_*
+  ;; If called from the statically linked Guile, use Guile core 'umount'.
+  ;; Otherwise, use an FFI binding to define 'umount'.
+  ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
+  (if (module-defined? the-scm-module 'umount)
+      (module-ref the-scm-module 'umount)
+      (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_*
 constants from <sys/mount.h>."
-      (let-values (((ret err)
-                    (proc (string->pointer target) flags)))
-        (unless (zero? ret)
-          (throw 'system-error "umount" "~S: ~A"
-                 (list target (strerror err))
-                 (list err)))
-        (when update-mtab?
-          (remove-from-mtab target))))))
+          (let-values (((ret err)
+                        (proc (string->pointer target) flags)))
+            (unless (zero? ret)
+              (throw 'system-error "umount" "~S: ~A"
+                     (list target (strerror err))
+                     (list err)))
+            (when update-mtab?
+              (remove-from-mtab target)))))))
 
 (define (mount-points)
   "Return the mounts points for currently mounted file systems."
-- 
2.12.2

bug#26341: [PATCH 2/2] build: vm: Add missing module.

[Mathieu Othacehe]

* gnu/build/vm.scm (define-module): Use module (guix build syscalls).

It fixes the following warnings during guix build :

gnu/build/vm.scm:233:3: warning: possibly unbound variable `mount'
gnu/build/vm.scm:238:3: warning: possibly unbound variable `umount'
gnu/build/vm.scm:268:8: warning: possibly unbound variable `mount'
gnu/build/vm.scm:276:8: warning: possibly unbound variable `umount'
gnu/build/vm.scm:315:4: warning: possibly unbound variable `mount'
gnu/build/vm.scm:323:4: warning: possibly unbound variable `umount'

This was not possible until commit f05346979 because we had to be sure
that Guile core implementation of 'mount' and 'umount' was used in
initrd context.
---
 gnu/build/vm.scm | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 60ee18ebe..44a3000eb 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -21,6 +21,7 @@
 (define-module (gnu build vm)
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
+  #:use-module (guix build syscalls)
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
   #:use-module (guix records)
-- 
2.12.2

bug#26341: [PATCH] build: vm: Add missing module.

[Ludovic Courtès]

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

>> That introduces a slight difference: in one case #:update-mtab? is not
>> honored.  That said, it’s probably OK to ignore it; maybe leave an “XXX”
>> comment above just in case.  ;-)
>
> Ok !
>
>> Can you send a ‘git format-patch’ thing?  (Otherwise I could write the
>> commit log on your behalf.)
>
> Sure, I'll send new patches !
>
> I have a follow-up question. Would it be ok to do the same thing for
> other warnings on syscalls, 'reboot' for example ?

Sure!  Likewise for ‘network-interface-flags’ and
‘set-network-interface-flags’, which guile-linux-syscalls.patch defines
in exactly the same way as (guix build syscalls).

Thanks,
Ludo’.

bug#26341: [PATCH] build: vm: Add missing module.

[Ludovic Courtès]

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

> Mathieu Othacehe <m.othacehe@gmail.com> skribis:
>
>>> That introduces a slight difference: in one case #:update-mtab? is not
>>> honored.  That said, it’s probably OK to ignore it; maybe leave an “XXX”
>>> comment above just in case.  ;-)
>>
>> Ok !
>>
>>> Can you send a ‘git format-patch’ thing?  (Otherwise I could write the
>>> commit log on your behalf.)
>>
>> Sure, I'll send new patches !
>>
>> I have a follow-up question. Would it be ok to do the same thing for
>> other warnings on syscalls, 'reboot' for example ?
>
> Sure!  Likewise for ‘network-interface-flags’ and
> ‘set-network-interface-flags’, which guile-linux-syscalls.patch defines
> in exactly the same way as (guix build syscalls).

I’ve applied the first patches in the meantime.

I noticed that we get this at boot time (from the initrd):

  WARNING: (gnu build file-systems): imported module (guix build syscalls) overrides core binding `mount'

To get rid of it, (guix build syscalls) should in fact #:re-export those
bindings (or #:replace).  Annoying.

Ludo’.

bug#26341: [PATCH] build: vm: Add missing module.

[Mathieu Othacehe]

Hi Ludo,

> To get rid of it, (guix build syscalls) should in fact #:re-export those
> bindings (or #:replace).  Annoying.

Thanks for applying.

Yes I saw, I'll propose a serie soon that fixes all those warnings at
compilation time and run-time.

Mathieu

bug#26341: [PATCH 0/5] Fix warnings related to syscalls in static Guile.

[Mathieu Othacehe]

This serie fixes the remaining warnings both at compilation
and during initrd execution.

Thank you,

Mathieu

Mathieu Othacehe (5):
  build: syscalls: Add reboot.
  build: syscalls: Allow use to network-interface syscalls independently
    of calling context.
  build: syscalls: Add mount and umount to #:replace list.
  build: syscalls: Add load-linux-module.
  build: Fix compilation warnings.

 gnu/build/file-systems.scm  |  15 +--
 gnu/build/linux-boot.scm    |   2 +
 gnu/build/linux-modules.scm |   2 +
 guix/build/syscalls.scm     | 258 +++++++++++++++++++++++++++-----------------
 4 files changed, 163 insertions(+), 114 deletions(-)

-- 
2.12.2

bug#26341: [PATCH 1/5] build: syscalls: Add reboot.

[Mathieu Othacehe]

* guix/build/syscalls.scm (static-or-ffi): New macro. Used to dispatch between
  static Guile core implementation and FFI version.
(reboot): New export procedure. Reimplemented from guile-linux-syscalls.patch.
(RB_AUTOBOOT, ..., RB_KEXEC): New exported flags replacing static Guile flags.
---
 guix/build/syscalls.scm | 36 +++++++++++++++++++++++++++++++++++-
 1 file changed, 35 insertions(+), 1 deletion(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 4bcb2a871..af5ec4b6a 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -144,7 +145,15 @@
             utmpx-address
             login-type
             utmpx-entries
-            (read-utmpx-from-port . read-utmpx)))
+            (read-utmpx-from-port . read-utmpx))
+  #:replace (RB_AUTOBOOT
+             RB_HALT_SYSTEM
+             RB_ENABLED_CAD
+             RB_DISABLE_CAD
+             RB_POWER_OFF
+             RB_SW_SUSPEND
+             RB_KEXEC
+             reboot))
 
 ;;; Commentary:
 ;;;
@@ -409,6 +418,13 @@ the returned procedure is called."
         (error (format #f "~a: syscall->procedure failed: ~s"
                        name args))))))
 
+(define-syntax-rule (static-or-ffi symbol ffi-procedure)
+  "If SYMBOL is defined in the core Guile module, return the associated
+procedure, otherwise return FFI-PROCEDURE."
+  (if (module-defined? the-scm-module symbol)
+      (module-ref the-scm-module symbol)
+      ffi-procedure))
+
 \f
 ;;;
 ;;; File systems.
@@ -547,6 +563,24 @@ constants from <sys/mount.h>."
                  (list device (strerror err))
                  (list err)))))))
 
+(define RB_AUTOBOOT    #x01234567)
+(define RB_HALT_SYSTEM #xcdef0123)
+(define RB_ENABLED_CAD #x89abcdef)
+(define RB_DISABLE_CAD 0)
+(define RB_POWER_OFF   #x4321fedc)
+(define RB_SW_SUSPEND  #xd000fce2)
+(define RB_KEXEC       #x45584543)
+
+(define reboot
+  (static-or-ffi
+   'reboot
+   (let ((proc (syscall->procedure int "reboot" (list int))))
+     (lambda* (#:optional (cmd RB_AUTOBOOT))
+       (let-values (((ret err) (proc cmd)))
+         (unless (zero? ret)
+           (throw 'system-error "reboot" "~S: ~A"
+                  (list cmd (strerror err))
+                  (list err))))))))
 (define (kernel? pid)
   "Return #t if PID designates a \"kernel thread\" rather than a normal
 user-land process."
-- 
2.12.2

bug#26341: [PATCH 2/5] build: syscalls: Allow use to network-interface syscalls independently of calling context.

[Mathieu Othacehe]

* guix/build/syscalls.scm (network-interface-flags): Use static-or-ffi macro
  and add to #:replace list.
(set-network-interface-flags): Ditto.
(set-network-interface-address): Ditto.
(IFF_UP, IFF_BROADCAST and IFF_LOOPBACK): Move from #:export to #:replace.
---
 guix/build/syscalls.scm | 123 ++++++++++++++++++++++++++----------------------
 1 file changed, 66 insertions(+), 57 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index af5ec4b6a..6afbfb86e 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -84,17 +84,11 @@
 
             PF_PACKET
             AF_PACKET
-            IFF_UP
-            IFF_BROADCAST
-            IFF_LOOPBACK
             all-network-interface-names
             network-interface-names
-            network-interface-flags
             network-interface-netmask
             loopback-network-interface?
             network-interface-address
-            set-network-interface-flags
-            set-network-interface-address
             set-network-interface-netmask
             set-network-interface-up
             configure-network-interface
@@ -153,7 +147,13 @@
              RB_POWER_OFF
              RB_SW_SUSPEND
              RB_KEXEC
-             reboot))
+             reboot
+             IFF_UP
+             IFF_BROADCAST
+             IFF_LOOPBACK
+             network-interface-flags
+             set-network-interface-flags
+             set-network-interface-address))
 
 ;;; Commentary:
 ;;;
@@ -1066,26 +1066,29 @@ that are not up."
                 (else
                  (loop interfaces))))))))
 
-(define (network-interface-flags socket name)
-  "Return a number that is the bit-wise or of 'IFF*' flags for network
+(define network-interface-flags
+  (static-or-ffi
+   'network-interface-flags
+   (lambda (socket name)
+     "Return a number that is the bit-wise or of 'IFF*' flags for network
 interface NAME."
-  (let ((req (make-bytevector ifreq-struct-size)))
-    (bytevector-copy! (string->utf8 name) 0 req 0
-                      (min (string-length name) (- IF_NAMESIZE 1)))
-    (let-values (((ret err)
-                  (%ioctl (fileno socket) SIOCGIFFLAGS
-                          (bytevector->pointer req))))
-      (if (zero? ret)
-
-          ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of
-          ;; 'struct ifreq', and it's a short int.
-          (bytevector-sint-ref req IF_NAMESIZE (native-endianness)
-                               (sizeof short))
-
-          (throw 'system-error "network-interface-flags"
-                 "network-interface-flags on ~A: ~A"
-                 (list name (strerror err))
-                 (list err))))))
+     (let ((req (make-bytevector ifreq-struct-size)))
+       (bytevector-copy! (string->utf8 name) 0 req 0
+                         (min (string-length name) (- IF_NAMESIZE 1)))
+       (let-values (((ret err)
+                     (%ioctl (fileno socket) SIOCGIFFLAGS
+                             (bytevector->pointer req))))
+         (if (zero? ret)
+
+             ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the
+             ;; beginning of 'struct ifreq', and it's a short int.
+             (bytevector-sint-ref req IF_NAMESIZE (native-endianness)
+                                  (sizeof short))
+
+             (throw 'system-error "network-interface-flags"
+                    "network-interface-flags on ~A: ~A"
+                    (list name (strerror err))
+                    (list err))))))))
 
 (define (loopback-network-interface? name)
   "Return true if NAME designates a loopback network interface."
@@ -1094,38 +1097,44 @@ interface NAME."
     (close-port sock)
     (not (zero? (logand flags IFF_LOOPBACK)))))
 
-(define (set-network-interface-flags socket name flags)
-  "Set the flag of network interface NAME to FLAGS."
-  (let ((req (make-bytevector ifreq-struct-size)))
-    (bytevector-copy! (string->utf8 name) 0 req 0
-                      (min (string-length name) (- IF_NAMESIZE 1)))
-    ;; Set the 'ifr_flags' field.
-    (bytevector-uint-set! req IF_NAMESIZE flags (native-endianness)
-                          (sizeof short))
-    (let-values (((ret err)
-                  (%ioctl (fileno socket) SIOCSIFFLAGS
-                          (bytevector->pointer req))))
-      (unless (zero? ret)
-        (throw 'system-error "set-network-interface-flags"
-               "set-network-interface-flags on ~A: ~A"
-               (list name (strerror err))
-               (list err))))))
+(define set-network-interface-flags
+  (static-or-ffi
+   'set-network-interface-flags
+   (lambda (socket name flags)
+     "Set the flag of network interface NAME to FLAGS."
+     (let ((req (make-bytevector ifreq-struct-size)))
+       (bytevector-copy! (string->utf8 name) 0 req 0
+                         (min (string-length name) (- IF_NAMESIZE 1)))
+       ;; Set the 'ifr_flags' field.
+       (bytevector-uint-set! req IF_NAMESIZE flags (native-endianness)
+                             (sizeof short))
+       (let-values (((ret err)
+                     (%ioctl (fileno socket) SIOCSIFFLAGS
+                             (bytevector->pointer req))))
+         (unless (zero? ret)
+           (throw 'system-error "set-network-interface-flags"
+                  "set-network-interface-flags on ~A: ~A"
+                  (list name (strerror err))
+                  (list err))))))))
 
-(define (set-network-interface-address socket name sockaddr)
-  "Set the address of network interface NAME to SOCKADDR."
-  (let ((req (make-bytevector ifreq-struct-size)))
-    (bytevector-copy! (string->utf8 name) 0 req 0
-                      (min (string-length name) (- IF_NAMESIZE 1)))
-    ;; Set the 'ifr_addr' field.
-    (write-socket-address! sockaddr req IF_NAMESIZE)
-    (let-values (((ret err)
-                  (%ioctl (fileno socket) SIOCSIFADDR
-                          (bytevector->pointer req))))
-      (unless (zero? ret)
-        (throw 'system-error "set-network-interface-address"
-               "set-network-interface-address on ~A: ~A"
-               (list name (strerror err))
-               (list err))))))
+(define set-network-interface-address
+  (static-or-ffi
+   'set-network-interface-address
+   (lambda (socket name sockaddr)
+     "Set the address of network interface NAME to SOCKADDR."
+     (let ((req (make-bytevector ifreq-struct-size)))
+       (bytevector-copy! (string->utf8 name) 0 req 0
+                         (min (string-length name) (- IF_NAMESIZE 1)))
+       ;; Set the 'ifr_addr' field.
+       (write-socket-address! sockaddr req IF_NAMESIZE)
+       (let-values (((ret err)
+                     (%ioctl (fileno socket) SIOCSIFADDR
+                             (bytevector->pointer req))))
+         (unless (zero? ret)
+           (throw 'system-error "set-network-interface-address"
+                  "set-network-interface-address on ~A: ~A"
+                  (list name (strerror err))
+                  (list err))))))))
 
 (define (set-network-interface-netmask socket name sockaddr)
   "Set the network mask of interface NAME to SOCKADDR."
-- 
2.12.2

bug#26341: [PATCH 3/5] build: syscalls: Add mount and umount to #:replace list.

[Mathieu Othacehe]

* guix/build/syscalls.scm (mount): Use static-or-ffi macro
  and move from #:export list to #:replace list.
(umount): Ditto.
---
 guix/build/syscalls.scm | 86 +++++++++++++++++++++++--------------------------
 1 file changed, 41 insertions(+), 45 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 6afbfb86e..42071e7b1 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -45,8 +45,6 @@
             MNT_EXPIRE
             UMOUNT_NOFOLLOW
             restart-on-EINTR
-            mount
-            umount
             mount-points
             swapon
             swapoff
@@ -140,7 +138,9 @@
             login-type
             utmpx-entries
             (read-utmpx-from-port . read-utmpx))
-  #:replace (RB_AUTOBOOT
+  #:replace (mount
+             umount
+             RB_AUTOBOOT
              RB_HALT_SYSTEM
              RB_ENABLED_CAD
              RB_DISABLE_CAD
@@ -478,57 +478,53 @@ procedure, otherwise return FFI-PROCEDURE."
 (define UMOUNT_NOFOLLOW 8)
 
 (define mount
-  ;; If called from the statically linked Guile, use Guile core 'mount'.
-  ;; Otherwise, use an FFI binding to define 'mount'.
   ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
-  (if (module-defined? the-scm-module 'mount)
-      (module-ref the-scm-module 'mount)
-      (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.
+  (static-or-ffi
+   'mount
+   (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 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-values (((ret err)
-                        (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))))
-            (unless (zero? ret)
-              (throw 'system-error "mount" "mount ~S on ~S: ~A"
-                     (list source target (strerror err))
-                     (list err)))
-            (when update-mtab?
-              (augment-mtab source target type options)))))))
+       (let-values (((ret err)
+                     (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))))
+         (unless (zero? ret)
+           (throw 'system-error "mount" "mount ~S on ~S: ~A"
+                  (list source target (strerror err))
+                  (list err)))
+         (when update-mtab?
+           (augment-mtab source target type options)))))))
 
 (define umount
-  ;; If called from the statically linked Guile, use Guile core 'umount'.
-  ;; Otherwise, use an FFI binding to define 'umount'.
   ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
-  (if (module-defined? the-scm-module 'umount)
-      (module-ref the-scm-module 'umount)
-      (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_*
+  (static-or-ffi
+   'umount
+   (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_*
 constants from <sys/mount.h>."
-          (let-values (((ret err)
-                        (proc (string->pointer target) flags)))
-            (unless (zero? ret)
-              (throw 'system-error "umount" "~S: ~A"
-                     (list target (strerror err))
-                     (list err)))
-            (when update-mtab?
-              (remove-from-mtab target)))))))
+       (let-values (((ret err)
+                     (proc (string->pointer target) flags)))
+         (unless (zero? ret)
+           (throw 'system-error "umount" "~S: ~A"
+                  (list target (strerror err))
+                  (list err)))
+         (when update-mtab?
+           (remove-from-mtab target)))))))
 
 (define (mount-points)
   "Return the mounts points for currently mounted file systems."
-- 
2.12.2

bug#26341: [PATCH 4/5] build: syscalls: Add load-linux-module.

[Mathieu Othacehe]

* guix/build/syscalls.scm (load-linux-module): New procedure. Reimplemented
  from guile-linux-syscalls.patch. Add to #:replace list.
---
 guix/build/syscalls.scm | 17 +++++++++++++++++
 1 file changed, 17 insertions(+)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 42071e7b1..14d97fb61 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -148,6 +148,7 @@
              RB_SW_SUSPEND
              RB_KEXEC
              reboot
+             load-linux-module
              IFF_UP
              IFF_BROADCAST
              IFF_LOOPBACK
@@ -577,6 +578,22 @@ constants from <sys/mount.h>."
            (throw 'system-error "reboot" "~S: ~A"
                   (list cmd (strerror err))
                   (list err))))))))
+
+(define load-linux-module
+  (static-or-ffi
+   'load-linux-module
+   (let ((proc (syscall->procedure int "init_module"
+                                   (list '* unsigned-long '*))))
+     (lambda* (data #:optional (options ""))
+       (let-values (((ret err)
+                     (proc (bytevector->pointer data)
+                           (bytevector-length data)
+                           (string->pointer options))))
+         (unless (zero? ret)
+           (throw 'system-error "load-linux-module" "~A"
+                  (list (strerror err))
+                  (list err))))))))
+
 (define (kernel? pid)
   "Return #t if PID designates a \"kernel thread\" rather than a normal
 user-land process."
-- 
2.12.2

bug#26341: [PATCH 5/5] build: Fix compilation warnings.

[Mathieu Othacehe]

* gnu/build/linux-boot.scm (define-module): Use (guix build syscalls).
* gnu/build/linux-modules.scm (define-module): Ditto.
* gnu/build/file-systems (define-module): Stop re-exporting mount, umount and
  MS_* flags as this is now safe to include (guix build syscalls) instead.
  (mount): Remove procedure.
  (umount): Ditto.
---
 gnu/build/file-systems.scm  | 15 ++-------------
 gnu/build/linux-boot.scm    |  2 ++
 gnu/build/linux-modules.scm |  2 ++
 3 files changed, 6 insertions(+), 13 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index fe98df95d..eb9f07861 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -47,12 +48,7 @@
 
             mount-flags->bit-mask
             check-file-system
-            mount-file-system)
-  #:re-export (mount
-               umount
-               MS_BIND
-               MS_MOVE
-               MS_RDONLY))
+            mount-file-system))
 
 ;;; Commentary:
 ;;;
@@ -61,13 +57,6 @@
 ;;;
 ;;; Code:
 
-;; 'mount' is already defined in the statically linked Guile used for initial
-;; RAM disks, in which case the bindings in (guix build syscalls) do not work
-;; (the FFI bindings do not work there).  Override them in that case.
-(when (module-defined? the-scm-module 'mount)
-  (set! mount (@ (guile) mount))
-  (set! umount (@ (guile) umount)))
-
 (define (bind-mount source target)
   "Bind-mount SOURCE at TARGET."
   (mount source target "" MS_BIND))
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index c34a3f7c1..360ef3fae 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 ftw)
   #:use-module (guix build utils)
+  #:use-module (guix build syscalls)
   #:use-module (gnu build linux-modules)
   #:use-module (gnu build file-systems)
   #:export (mount-essential-file-systems
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index d7feb3a08..5ca7bf8e3 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,6 +19,7 @@
 
 (define-module (gnu build linux-modules)
   #:use-module (guix elf)
+  #:use-module (guix build syscalls)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
-- 
2.12.2

bug#26341: [PATCH 1/5] build: syscalls: Add reboot.

[Ludovic Courtès]

Hi Mathieu,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> * guix/build/syscalls.scm (static-or-ffi): New macro. Used to dispatch between
>   static Guile core implementation and FFI version.
> (reboot): New export procedure. Reimplemented from guile-linux-syscalls.patch.
> (RB_AUTOBOOT, ..., RB_KEXEC): New exported flags replacing static Guile flags.

[...]

> +  #:replace (RB_AUTOBOOT
> +             RB_HALT_SYSTEM
> +             RB_ENABLED_CAD
> +             RB_DISABLE_CAD
> +             RB_POWER_OFF
> +             RB_SW_SUSPEND
> +             RB_KEXEC
> +             reboot))

The problem is that we cannot #:replace unconditionally (when not using
the patched Guile, there’s nothing to replace¹).

So perhaps we should remove #:export, #:replace, and #:re-export for
‘mount’ & co, and instead have a macro like this:

  (define-syntax define-as-needed
    (syntax-rules ()
      "Define VARIABLE.  If VARIABLE already exists in (guile) then re-export it,
  otherwise export the newly-defined VARIABLE."
      ((_ (proc args ...) body ...)
       (define-as-needed proc (lambda (args ...) body ...)))
      ((_ variable value)
       (begin
         (when (module-defined? the-scm-module 'variable)
           (re-export variable))

         (define variable
           (if (module-defined? the-scm-module 'variable)
               (module-ref the-scm-module 'variable)
               value))

         (unless (module-defined? the-scm-module 'variable)
           (export variable))))))

  (define-as-needed RB_AUTOBOOT #x123)
  (define-as-needed (mount foo bar)
    'baz)

WDYT?

Sorry that this simple thing ends up being complicated!  ;-)

Thank you,
Ludo’.

¹ In practice #:replace works even when there’s nothing to replace, but
  I’d rather not rely on it.

bug#26341: [PATCH 1/5] build: syscalls: Add reboot.

[Mathieu Othacehe]

Hey Ludo,

> The problem is that we cannot #:replace unconditionally (when not using
> the patched Guile, there’s nothing to replace¹).

Yes I was relying on #:replace ability to just export the symbol if
there's nothing to replace (as explained in your note¹).

>
> WDYT?

Anyway, your macro seems a nicer way than dealing with export/replace.
I gave it a try and everything still seems warning free.

My only concern is that it won't be obvious for people who want to use
reboot or mount or any other syscall that they have to use (guix build
syscalls) because the #:export list won't contain those syscalls.

Maybe a big explanation on top of the file would be enough ?

Thanks,

Mathieu

bug#26341: [PATCH 1/5] build: syscalls: Add reboot.

[Ludovic Courtès]

Hi,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

>> The problem is that we cannot #:replace unconditionally (when not using
>> the patched Guile, there’s nothing to replace¹).
>
> Yes I was relying on #:replace ability to just export the symbol if
> there's nothing to replace (as explained in your note¹).
>
>>
>> WDYT?
>
> Anyway, your macro seems a nicer way than dealing with export/replace.
> I gave it a try and everything still seems warning free.
>
> My only concern is that it won't be obvious for people who want to use
> reboot or mount or any other syscall that they have to use (guix build
> syscalls) because the #:export list won't contain those syscalls.
>
> Maybe a big explanation on top of the file would be enough ?

Yes, I think it would be enough.

Also, the initrd is the only context where one can omit (use-modules
(guix build syscalls)) so I think people will choose to use it by
default.

Thanks,
Ludo’.

bug#26341: [PATCH 1/5] build: syscalls: Add reboot.

[Mathieu Othacehe]

> Yes, I think it would be enough.

Ok so, here's a new serie using this macro !

Thanks,

Mathieu

bug#26341: [PATCH 1/5] build: syscalls: Add reboot.

[Mathieu Othacehe]

* guix/build/syscalls.scm (define-as-needed): New macro.
(reboot): New procedure. Reimplemented from guile-linux-syscalls.patch.
(RB_AUTOBOOT, ..., RB_KEXEC): New flags copied from static Guile patch.

Co-Authored-By: Ludovic Courtès <ludo@gnu.org>
---
 guix/build/syscalls.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 49 insertions(+), 2 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 4bcb2a871..0de39aee6 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -149,8 +150,19 @@
 ;;; Commentary:
 ;;;
 ;;; This module provides bindings to libc's syscall wrappers.  It uses the
-;;; FFI, and thus requires a dynamically-linked Guile.  (For statically-linked
-;;; Guile, we instead apply 'guile-linux-syscalls.patch'.)
+;;; FFI, and thus requires a dynamically-linked Guile.
+;;;
+;;; Some syscalls are already defined in statically-linked Guile by applying
+;;; 'guile-linux-syscalls.patch'.
+;;;
+;;; Visibility of syscall's symbols shared between this module and static Guile
+;;; is a bit delicate. It is handled by 'define-as-needed' macro.
+;;;
+;;; This macro is used to export symbols in dynamic Guile context, and to
+;;; re-export them in static Guile context.
+;;;
+;;; This way, even if they don't appear in #:export list, it is safe to use
+;;; syscalls from this module in static or dynamic Guile context.
 ;;;
 ;;; Code:
 
@@ -409,6 +421,25 @@ the returned procedure is called."
         (error (format #f "~a: syscall->procedure failed: ~s"
                        name args))))))
 
+(define-syntax define-as-needed
+  (syntax-rules ()
+    "Define VARIABLE.  If VARIABLE already exists in (guile) then re-export it,
+  otherwise export the newly-defined VARIABLE."
+    ((_ (proc args ...) body ...)
+     (define-as-needed proc (lambda* (args ...) body ...)))
+    ((_ variable value)
+     (begin
+       (when (module-defined? the-scm-module 'variable)
+         (re-export variable))
+
+       (define variable
+         (if (module-defined? the-scm-module 'variable)
+             (module-ref the-scm-module 'variable)
+             value))
+
+       (unless (module-defined? the-scm-module 'variable)
+         (export variable))))))
+
 \f
 ;;;
 ;;; File systems.
@@ -547,6 +578,22 @@ constants from <sys/mount.h>."
                  (list device (strerror err))
                  (list err)))))))
 
+(define-as-needed RB_AUTOBOOT    #x01234567)
+(define-as-needed RB_HALT_SYSTEM #xcdef0123)
+(define-as-needed RB_ENABLED_CAD #x89abcdef)
+(define-as-needed RB_DISABLE_CAD 0)
+(define-as-needed RB_POWER_OFF   #x4321fedc)
+(define-as-needed RB_SW_SUSPEND  #xd000fce2)
+(define-as-needed RB_KEXEC       #x45584543)
+
+(define-as-needed (reboot #:optional (cmd RB_AUTOBOOT))
+  (let ((proc (syscall->procedure int "reboot" (list int))))
+    (let-values (((ret err) (proc cmd)))
+      (unless (zero? ret)
+        (throw 'system-error "reboot" "~S: ~A"
+               (list cmd (strerror err))
+               (list err))))))
+
 (define (kernel? pid)
   "Return #t if PID designates a \"kernel thread\" rather than a normal
 user-land process."
-- 
2.12.2

bug#26341: [PATCH 2/5] build: syscalls: Use define-as-needed for mount and umount.

[Mathieu Othacehe]

* guix/build/syscalls.scm (mount): Use define-as-needed macro
  and remove from export list.
(umount): Ditto.
---
 guix/build/syscalls.scm | 86 ++++++++++++++++++++++---------------------------
 1 file changed, 38 insertions(+), 48 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 0de39aee6..79a0da7c5 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -45,8 +45,6 @@
             MNT_EXPIRE
             UMOUNT_NOFOLLOW
             restart-on-EINTR
-            mount
-            umount
             mount-points
             swapon
             swapoff
@@ -492,58 +490,50 @@ the returned procedure is called."
 (define MNT_EXPIRE      4)
 (define UMOUNT_NOFOLLOW 8)
 
-(define mount
-  ;; If called from the statically linked Guile, use Guile core 'mount'.
-  ;; Otherwise, use an FFI binding to define 'mount'.
-  ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
-  (if (module-defined? the-scm-module 'mount)
-      (module-ref the-scm-module 'mount)
-      (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
-        (lambda* (source target type #:optional (flags 0) options
+(define-as-needed (mount source target type
+                         #:optional (flags 0) options
                          #:key (update-mtab? #f))
-          "Mount device SOURCE on TARGET as a file system TYPE.
+  "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-values (((ret err)
-                        (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))))
-            (unless (zero? ret)
-              (throw 'system-error "mount" "mount ~S on ~S: ~A"
-                     (list source target (strerror err))
-                     (list err)))
-            (when update-mtab?
-              (augment-mtab source target type options)))))))
-
-(define umount
-  ;; If called from the statically linked Guile, use Guile core 'umount'.
-  ;; Otherwise, use an FFI binding to define 'umount'.
-  ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
-  (if (module-defined? the-scm-module 'umount)
-      (module-ref the-scm-module 'umount)
-      (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_*
+  ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
+  (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
+    (let-values (((ret err)
+                  (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))))
+      (unless (zero? ret)
+        (throw 'system-error "mount" "mount ~S on ~S: ~A"
+               (list source target (strerror err))
+               (list err)))
+      (when update-mtab?
+        (augment-mtab source target type options)))))
+
+(define-as-needed (umount 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-values (((ret err)
-                        (proc (string->pointer target) flags)))
-            (unless (zero? ret)
-              (throw 'system-error "umount" "~S: ~A"
-                     (list target (strerror err))
-                     (list err)))
-            (when update-mtab?
-              (remove-from-mtab target)))))))
+  ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
+  (let ((proc (syscall->procedure int "umount2" `(* ,int))))
+    (let-values (((ret err)
+                  (proc (string->pointer target) flags)))
+      (unless (zero? ret)
+        (throw 'system-error "umount" "~S: ~A"
+               (list target (strerror err))
+               (list err)))
+      (when update-mtab?
+        (remove-from-mtab target)))))
 
 (define (mount-points)
   "Return the mounts points for currently mounted file systems."
-- 
2.12.2

bug#26341: [PATCH 3/5] build: syscalls: Use define-as-needed for network-interface syscalls.

[Mathieu Othacehe]

* guix/build/syscalls.scm (network-interface-flags): Use define-as-needed macro
  and remove from export list.
(set-network-interface-flags): Ditto.
(set-network-interface-address): Ditto.
(IFF_UP, IFF_BROADCAST and IFF_LOOPBACK): Ditto.
---
 guix/build/syscalls.scm | 22 ++++++++--------------
 1 file changed, 8 insertions(+), 14 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 79a0da7c5..d1f3cd65c 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -82,17 +82,11 @@
 
             PF_PACKET
             AF_PACKET
-            IFF_UP
-            IFF_BROADCAST
-            IFF_LOOPBACK
             all-network-interface-names
             network-interface-names
-            network-interface-flags
             network-interface-netmask
             loopback-network-interface?
             network-interface-address
-            set-network-interface-flags
-            set-network-interface-address
             set-network-interface-netmask
             set-network-interface-up
             configure-network-interface
@@ -920,9 +914,9 @@ exception if it's already taken."
 
 ;; Flags and constants from <net/if.h>.
 
-(define IFF_UP #x1)                               ;Interface is up
-(define IFF_BROADCAST #x2)                        ;Broadcast address valid.
-(define IFF_LOOPBACK #x8)                         ;Is a loopback net.
+(define-as-needed IFF_UP #x1)                     ;Interface is up
+(define-as-needed IFF_BROADCAST #x2)              ;Broadcast address valid.
+(define-as-needed IFF_LOOPBACK #x8)               ;Is a loopback net.
 
 (define IF_NAMESIZE 16)                           ;maximum interface name size
 
@@ -1069,7 +1063,7 @@ that are not up."
                 (else
                  (loop interfaces))))))))
 
-(define (network-interface-flags socket name)
+(define-as-needed (network-interface-flags socket name)
   "Return a number that is the bit-wise or of 'IFF*' flags for network
 interface NAME."
   (let ((req (make-bytevector ifreq-struct-size)))
@@ -1080,8 +1074,8 @@ interface NAME."
                           (bytevector->pointer req))))
       (if (zero? ret)
 
-          ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of
-          ;; 'struct ifreq', and it's a short int.
+          ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the
+          ;; beginning of 'struct ifreq', and it's a short int.
           (bytevector-sint-ref req IF_NAMESIZE (native-endianness)
                                (sizeof short))
 
@@ -1097,7 +1091,7 @@ interface NAME."
     (close-port sock)
     (not (zero? (logand flags IFF_LOOPBACK)))))
 
-(define (set-network-interface-flags socket name flags)
+(define-as-needed (set-network-interface-flags socket name flags)
   "Set the flag of network interface NAME to FLAGS."
   (let ((req (make-bytevector ifreq-struct-size)))
     (bytevector-copy! (string->utf8 name) 0 req 0
@@ -1114,7 +1108,7 @@ interface NAME."
                (list name (strerror err))
                (list err))))))
 
-(define (set-network-interface-address socket name sockaddr)
+(define-as-needed (set-network-interface-address socket name sockaddr)
   "Set the address of network interface NAME to SOCKADDR."
   (let ((req (make-bytevector ifreq-struct-size)))
     (bytevector-copy! (string->utf8 name) 0 req 0
-- 
2.12.2

bug#26341: [PATCH 4/5] build: syscalls: Add load-linux-module.

[Mathieu Othacehe]

* guix/build/syscalls.scm (load-linux-module): New procedure. Reimplemented
  from guile-linux-syscalls.patch.
---
 guix/build/syscalls.scm | 12 ++++++++++++
 1 file changed, 12 insertions(+)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index d1f3cd65c..0529c228a 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -578,6 +578,18 @@ constants from <sys/mount.h>."
                (list cmd (strerror err))
                (list err))))))
 
+(define-as-needed (load-linux-module data #:optional (options ""))
+  (let ((proc (syscall->procedure int "init_module"
+                                  (list '* unsigned-long '*))))
+    (let-values (((ret err)
+                  (proc (bytevector->pointer data)
+                        (bytevector-length data)
+                        (string->pointer options))))
+      (unless (zero? ret)
+        (throw 'system-error "load-linux-module" "~A"
+               (list (strerror err))
+               (list err))))))
+
 (define (kernel? pid)
   "Return #t if PID designates a \"kernel thread\" rather than a normal
 user-land process."
-- 
2.12.2

bug#26341: [PATCH 5/5] build: Fix compilation warnings.

[Mathieu Othacehe]

* gnu/build/linux-boot.scm (define-module): Use (guix build syscalls).
* gnu/build/linux-modules.scm (define-module): Ditto.
* gnu/build/file-systems (define-module): Stop re-exporting mount, umount and
  MS_* flags as this is now safe to include (guix build syscalls) instead.
  (mount): Remove procedure.
  (umount): Ditto.
---
 gnu/build/file-systems.scm  | 15 ++-------------
 gnu/build/linux-boot.scm    |  2 ++
 gnu/build/linux-modules.scm |  2 ++
 3 files changed, 6 insertions(+), 13 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index fe98df95d..eb9f07861 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -47,12 +48,7 @@
 
             mount-flags->bit-mask
             check-file-system
-            mount-file-system)
-  #:re-export (mount
-               umount
-               MS_BIND
-               MS_MOVE
-               MS_RDONLY))
+            mount-file-system))
 
 ;;; Commentary:
 ;;;
@@ -61,13 +57,6 @@
 ;;;
 ;;; Code:
 
-;; 'mount' is already defined in the statically linked Guile used for initial
-;; RAM disks, in which case the bindings in (guix build syscalls) do not work
-;; (the FFI bindings do not work there).  Override them in that case.
-(when (module-defined? the-scm-module 'mount)
-  (set! mount (@ (guile) mount))
-  (set! umount (@ (guile) umount)))
-
 (define (bind-mount source target)
   "Bind-mount SOURCE at TARGET."
   (mount source target "" MS_BIND))
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index c34a3f7c1..360ef3fae 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 ftw)
   #:use-module (guix build utils)
+  #:use-module (guix build syscalls)
   #:use-module (gnu build linux-modules)
   #:use-module (gnu build file-systems)
   #:export (mount-essential-file-systems
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index d7feb3a08..5ca7bf8e3 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,6 +19,7 @@
 
 (define-module (gnu build linux-modules)
   #:use-module (guix elf)
+  #:use-module (guix build syscalls)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
-- 
2.12.2

bug#26341: [PATCH 1/5] build: syscalls: Add reboot.

[Ludovic Courtès]

Hi!

Perfect, I removed “build:” from the subject line (it’s usually for
things that relate to the configury and makefiles) and pushed the whole
series.

Thank you!

Ludo’.

bug#26341: [PATCH 1/5] build: syscalls: Add reboot.

[Mathieu Othacehe]

Hi Ludo,

Thanks for merging :)

While we are talking of build warnings, the only remaining warnings are
related to cairo :

...
gnu/build/svg.scm:36:12: warning: possibly unbound variable `cairo-create'
gnu/build/svg.scm:36:26: warning: possibly unbound variable `cairo-image-surface-create'
gnu/build/svg.scm:38:4: warning: possibly unbound variable `cairo-scale'
gnu/build/svg.scm:39:4: warning: possibly unbound variable `cairo-set-source-surface'
...

This file mentions closed bug http://bugs.gnu.org/12202. Is there
something that can be done ?

Thank you,

Mathieu

bug#26341: [PATCH 1/5] build: syscalls: Add reboot.

[Ludovic Courtès]

Heya,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> While we are talking of build warnings, the only remaining warnings are
> related to cairo :
>
> ...
> gnu/build/svg.scm:36:12: warning: possibly unbound variable `cairo-create'
> gnu/build/svg.scm:36:26: warning: possibly unbound variable `cairo-image-surface-create'
> gnu/build/svg.scm:38:4: warning: possibly unbound variable `cairo-scale'
> gnu/build/svg.scm:39:4: warning: possibly unbound variable `cairo-set-source-surface'
> ...
>
> This file mentions closed bug http://bugs.gnu.org/12202. Is there
> something that can be done ?

Good question!  In fact it doesn’t make much sense to have ‘make’
compile this file since it’s only used on the “build side”, from (gnu
system grub).

So perhaps we should simply adjust Makefile.am & co. to not build this
file.  Thoughts?

(I think there’s a couple of other files in a similar situation.)

Ludo’.