nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Mark H Weaver 2016-02-10 14:17:33 +02:00 committed by Ludovic Courtès
parent dd1d09f7e4
commit 4f8cede062
1 changed files with 26 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
guix/build/syscalls.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -145,6 +146,19 @@
"Evaluate EXPR and restart upon EINTR. Return the value of EXPR." "Evaluate EXPR and restart upon EINTR. Return the value of EXPR."
(call-with-restart-on-EINTR (lambda () 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) (define (augment-mtab source target type options)
"Augment /etc/mtab with information about the given mount point." "Augment /etc/mtab with information about the given mount point."
(let ((port (open-file "/etc/mtab" "a"))) (let ((port (open-file "/etc/mtab" "a")))
@ -193,8 +207,7 @@
(define UMOUNT_NOFOLLOW 8) (define UMOUNT_NOFOLLOW 8)
(define mount (define mount
(let* ((ptr (dynamic-func "mount" (dynamic-link))) (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
(proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
(lambda* (source target type #:optional (flags 0) options (lambda* (source target type #:optional (flags 0) options
#:key (update-mtab? #f)) #:key (update-mtab? #f))
"Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS "Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS
@ -222,8 +235,7 @@ error."
(augment-mtab source target type options)))))) (augment-mtab source target type options))))))
(define umount (define umount
(let* ((ptr (dynamic-func "umount2" (dynamic-link))) (let ((proc (syscall->procedure int "umount2" `(* ,int))))
(proc (pointer->procedure int ptr `(* ,int))))
(lambda* (target #:optional (flags 0) (lambda* (target #:optional (flags 0)
#:key (update-mtab? #f)) #:key (update-mtab? #f))
"Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
@ -250,8 +262,7 @@ constants from <sys/mount.h>."
(loop (cons mount-point result)))))))))) (loop (cons mount-point result))))))))))
(define swapon (define swapon
(let* ((ptr (dynamic-func "swapon" (dynamic-link))) (let ((proc (syscall->procedure int "swapon" (list '* int))))
(proc (pointer->procedure int ptr (list '* int))))
(lambda* (device #:optional (flags 0)) (lambda* (device #:optional (flags 0))
"Use the block special device at DEVICE for swapping." "Use the block special device at DEVICE for swapping."
(let ((ret (proc (string->pointer device) flags)) (let ((ret (proc (string->pointer device) flags))
@ -262,8 +273,7 @@ constants from <sys/mount.h>."
(list err))))))) (list err)))))))
(define swapoff (define swapoff
(let* ((ptr (dynamic-func "swapoff" (dynamic-link))) (let ((proc (syscall->procedure int "swapoff" '(*))))
(proc (pointer->procedure int ptr '(*))))
(lambda (device) (lambda (device)
"Stop using block special device DEVICE for swapping." "Stop using block special device DEVICE for swapping."
(let ((ret (proc (string->pointer device))) (let ((ret (proc (string->pointer device)))
@ -327,18 +337,18 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
;; declared in <unistd.h> as a variadic function; in practice, it expects 6 ;; declared in <unistd.h> as a variadic function; in practice, it expects 6
;; pointer-sized arguments, as shown in, e.g., x86_64/syscall.S. ;; pointer-sized arguments, as shown in, e.g., x86_64/syscall.S.
(define clone (define clone
(let* ((ptr (dynamic-func "syscall" (dynamic-link))) (let* ((proc (syscall->procedure int "syscall"
(proc (pointer->procedure long ptr (list long ;sysno
(list long ;sysno unsigned-long ;flags
unsigned-long ;flags '* '* '*
'* '* '* '*)))
'*)))
;; TODO: Don't do this. ;; TODO: Don't do this.
(syscall-id (match (utsname:machine (uname)) (syscall-id (match (utsname:machine (uname))
("i686" 120) ("i686" 120)
("x86_64" 56) ("x86_64" 56)
("mips64" 5055) ("mips64" 5055)
("armv7l" 120)))) ("armv7l" 120)
(_ #f))))
(lambda (flags) (lambda (flags)
"Create a new child process by duplicating the current parent process. "Create a new child process by duplicating the current parent process.
Unlike the fork system call, clone accepts FLAGS that specify which resources Unlike the fork system call, clone accepts FLAGS that specify which resources
@ -373,8 +383,7 @@ there is no such limitation."
(list err)))))))) (list err))))))))
(define pivot-root (define pivot-root
(let* ((ptr (dynamic-func "pivot_root" (dynamic-link))) (let ((proc (syscall->procedure int "pivot_root" (list '* '*))))
(proc (pointer->procedure int ptr (list '* '*))))
(lambda (new-root put-old) (lambda (new-root put-old)
"Change the root file system to NEW-ROOT and move the current root file "Change the root file system to NEW-ROOT and move the current root file
system to PUT-OLD." system to PUT-OLD."