>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