[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [PATCH] build: syscalls: Delay syscalls evaluation.
From: |
Mark H Weaver |
Subject: |
Re: [PATCH] build: syscalls: Delay syscalls evaluation. |
Date: |
Sat, 06 Feb 2016 12:36:24 -0500 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.5 (gnu/linux) |
Manolis Ragkousis <address@hidden> 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 <address@hidden>
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 <address@hidden>
;;; Copyright © 2015 David Thompson <address@hidden>
+;;; Copyright © 2015 Mark H Weaver <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -135,6 +136,19 @@
"Evaluate EXPR and restart upon EINTR. Return the value of EXPR."
(call-with-restart-on-EINTR (lambda () expr)))
+(define (syscall->procedure return-type name argument-types)
+ "Return a procedure that wraps the C function NAME using the dynamic FFI.
+If an error occurs while creating the binding, defer the error report until
+the returned procedure is called."
+ (catch #t
+ (lambda ()
+ (let ((ptr (dynamic-func name (dynamic-link))))
+ (pointer->procedure return-type ptr argument-types)))
+ (lambda args
+ (lambda _
+ (error (format #f "~a: syscall->procedure failed: ~s"
+ name args))))))
+
(define (augment-mtab source target type options)
"Augment /etc/mtab with information about the given mount point."
(let ((port (open-file "/etc/mtab" "a")))
@@ -183,8 +197,7 @@
(define UMOUNT_NOFOLLOW 8)
(define mount
- (let* ((ptr (dynamic-func "mount" (dynamic-link)))
- (proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
+ (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
(lambda* (source target type #:optional (flags 0) options
#:key (update-mtab? #f))
"Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS
@@ -212,8 +225,7 @@ error."
(augment-mtab source target type options))))))
(define umount
- (let* ((ptr (dynamic-func "umount2" (dynamic-link)))
- (proc (pointer->procedure int ptr `(* ,int))))
+ (let ((proc (syscall->procedure int "umount2" `(* ,int))))
(lambda* (target #:optional (flags 0)
#:key (update-mtab? #f))
"Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
@@ -240,8 +252,7 @@ constants from <sys/mount.h>."
(loop (cons mount-point result))))))))))
(define swapon
- (let* ((ptr (dynamic-func "swapon" (dynamic-link)))
- (proc (pointer->procedure int ptr (list '* int))))
+ (let ((proc (syscall->procedure int "swapon" (list '* int))))
(lambda* (device #:optional (flags 0))
"Use the block special device at DEVICE for swapping."
(let ((ret (proc (string->pointer device) flags))
@@ -252,8 +263,7 @@ constants from <sys/mount.h>."
(list err)))))))
(define swapoff
- (let* ((ptr (dynamic-func "swapoff" (dynamic-link)))
- (proc (pointer->procedure int ptr '(*))))
+ (let ((proc (syscall->procedure int "swapoff" '(*))))
(lambda (device)
"Stop using block special device DEVICE for swapping."
(let ((ret (proc (string->pointer device)))
@@ -313,8 +323,7 @@ string TMPL and return its file name. TMPL must end with
'XXXXXX'."
;; The libc interface to sys_clone is not useful for Scheme programs, so the
;; low-level system call is wrapped instead.
(define clone
- (let* ((ptr (dynamic-func "syscall" (dynamic-link)))
- (proc (pointer->procedure int ptr (list int int '*)))
+ (let ((proc (syscall->procedure int "syscall" (list int int '*)))
;; TODO: Don't do this.
(syscall-id (match (utsname:machine (uname))
("i686" 120)
@@ -328,8 +337,7 @@ are shared between the parent and child processes."
(proc syscall-id flags %null-pointer))))
(define setns
- (let* ((ptr (dynamic-func "setns" (dynamic-link)))
- (proc (pointer->procedure int ptr (list int int))))
+ (let ((proc (syscall->procedure int "setns" (list int int))))
(lambda (fdes nstype)
"Reassociate the current process with the namespace specified by FDES, a
file descriptor obtained by opening a /proc/PID/ns/* file. NSTYPE specifies
@@ -343,8 +351,7 @@ there is no such limitation."
(list err)))))))
(define pivot-root
- (let* ((ptr (dynamic-func "pivot_root" (dynamic-link)))
- (proc (pointer->procedure int ptr (list '* '*))))
+ (let ((proc (syscall->procedure int "pivot_root" (list '* '*))))
(lambda (new-root put-old)
"Change the root file system to NEW-ROOT and move the current root file
system to PUT-OLD."
--
2.5.0