From: Manolis Ragkousis <manolis837@gmail.com>
To: guix-devel@gnu.org
Cc: Justus Winter <4winter@informatik.uni-hamburg.de>
Subject: [PATCH] build: syscalls: Delay syscalls evaluation.
Date: Fri, 5 Feb 2016 15:01:40 +0200 [thread overview]
Message-ID: <56B49D34.1020705@gmail.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 531 bytes --]
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
[-- Attachment #2: 0001-build-syscalls-Delay-syscalls-evaluation.patch --]
[-- Type: text/x-patch, Size: 6929 bytes --]
From 0e05ab007e312800d22949543e935d9b91093aee Mon Sep 17 00:00:00 2001
From: Manolis Ragkousis <manolis837@gmail.com>
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_* <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 ((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 <sys/mount.h>."
- (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 <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* ((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)
(throw 'system-error "swapon" "~S: ~A"
@@ -254,11 +258,11 @@ constants from <sys/mount.h>."
(list err)))))))
(define swapoff
- (let* ((ptr (dynamic-func "swapoff" (dynamic-link)))
- (proc (pointer->procedure int ptr '(*))))
+ (let* ((ptr (delay (dynamic-func "swapoff" (dynamic-link))))
+ (proc (delay (pointer->procedure int (force ptr) '(*)))))
(lambda (device)
"Stop using block special device DEVICE for swapping."
- (let ((ret (proc (string->pointer device)))
+ (let ((ret ((force proc) (string->pointer device)))
(err (errno)))
(unless (zero? ret)
(throw 'system-error "swapoff" "~S: ~A"
@@ -326,16 +330,16 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
'* '* '*
'*)))
;; TODO: Don't do this.
- (syscall-id (match (utsname:machine (uname))
- ("i686" 120)
- ("x86_64" 56)
- ("mips64" 5055)
- ("armv7l" 120))))
+ (syscall-id (delay (match (utsname:machine (uname))
+ ("i686" 120)
+ ("x86_64" 56)
+ ("mips64" 5055)
+ ("armv7l" 120)))))
(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
are shared between the parent and child processes."
- (let ((ret (proc syscall-id flags
+ (let ((ret (proc (force syscall-id) flags
%null-pointer ;child stack
%null-pointer %null-pointer ;ptid & ctid
%null-pointer)) ;unused
@@ -365,12 +369,12 @@ 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* ((ptr (delay (dynamic-func "pivot_root" (dynamic-link))))
+ (proc (delay (pointer->procedure int (force ptr) (list '* '*)))))
(lambda (new-root put-old)
"Change the root file system to NEW-ROOT and move the current root file
system to PUT-OLD."
- (let ((ret (proc (string->pointer new-root)
+ (let ((ret ((force proc) (string->pointer new-root)
(string->pointer put-old)))
(err (errno)))
(unless (zero? ret)
--
2.6.4
next reply other threads:[~2016-02-05 13:01 UTC|newest]
Thread overview: 5+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-02-05 13:01 Manolis Ragkousis [this message]
2016-02-06 17:36 ` [PATCH] build: syscalls: Delay syscalls evaluation Mark H Weaver
2016-02-07 20:47 ` Ludovic Courtès
2016-02-10 12:53 ` Manolis Ragkousis
2016-04-18 17:39 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=56B49D34.1020705@gmail.com \
--to=manolis837@gmail.com \
--cc=4winter@informatik.uni-hamburg.de \
--cc=guix-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.