From mboxrd@z Thu Jan 1 00:00:00 1970 From: Manolis Ragkousis Subject: Re: [PATCH] build: syscalls: Delay syscalls evaluation. Date: Wed, 10 Feb 2016 14:53:52 +0200 Message-ID: <56BB32E0.4070909@gmail.com> References: <56B49D34.1020705@gmail.com> <878u2x4u7b.fsf@netris.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------070805060209060601010205" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:33907) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aTUHS-0000l0-QC for guix-devel@gnu.org; Wed, 10 Feb 2016 07:54:03 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aTUHR-0005xX-FJ for guix-devel@gnu.org; Wed, 10 Feb 2016 07:54:02 -0500 In-Reply-To: <878u2x4u7b.fsf@netris.org> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: Mark H Weaver Cc: guix-devel@gnu.org, Justus Winter <4winter@informatik.uni-hamburg.de> This is a multi-part message in MIME format. --------------070805060209060601010205 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 7bit 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 --------------070805060209060601010205 Content-Type: text/x-patch; name="0001-syscalls-If-a-syscall-is-not-available-defer-the-err.patch" Content-Transfer-Encoding: 8bit Content-Disposition: attachment; filename*0="0001-syscalls-If-a-syscall-is-not-available-defer-the-err.pa"; filename*1="tch" >From 761d4b04701b62042fba810b04da82ca2200b862 Mon Sep 17 00:00:00 2001 From: Mark H Weaver 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 ;;; Copyright © 2015 David Thompson +;;; Copyright © 2015 Mark H Weaver ;;; ;;; 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 ." (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 ." (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 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 --------------070805060209060601010205--