>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)
(throw 'system-error "swapon" "~S: ~A"
@@ -254,11 +258,11 @@ constants from ."
(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