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
>From 761d4b04701b62042fba810b04da82ca2200b862 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <m...@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 <l...@gnu.org>
;;; Copyright © 2015 David Thompson <da...@gnu.org>
+;;; Copyright © 2015 Mark H Weaver <m...@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
