Re: [PATCH] build: syscalls: Delay syscalls evaluation.
Manolis Ragkousis skribis: > 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. I’ve finally applied it. Sorry that it took no less than two months for something everyone had agreed on! Ludo’.
Re: [PATCH] build: syscalls: Delay syscalls evaluation.
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
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 'XX'."
;; 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)
Re: [PATCH] build: syscalls: Delay syscalls evaluation.
Mark H Weaver skribis: > From b283ad4097a48de11a616083da09ae0e76bab343 Mon Sep 17 00:00:00 2001 > From: Mark H Weaver > 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 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
>From b283ad4097a48de11a616083da09ae0e76bab343 Mon Sep 17 00:00:00 2001
From: Mark H Weaver
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
;;; Copyright © 2015 David Thompson
+;;; Copyright © 2015 Mark H Weaver
;;;
;;; 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 ."
(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 ."
(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 'XX'."
;; 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
-
[PATCH] build: syscalls: Delay syscalls evaluation.
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 >From 0e05ab007e312800d22949543e935d9b91093aee Mon Sep 17 00:00:00 2001 From: Manolis Ragkousis 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_* 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 ." - (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 ." (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)
