ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 13:58:15 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

syscalls: If a syscall is not available, defer the error.

Browse source 
* 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
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -145,6 +146,19 @@ (define-syntax-rule (restart-on-EINTR expr)
"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")))
@ -193,8 +207,7 @@ (define MNT_EXPIRE 4)
(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
@ -222,8 +235,7 @@ (define mount
(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_*
@ -250,8 +262,7 @@ (define (mount-points)
(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))
@ -262,8 +273,7 @@ (define swapon
(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)))
@ -327,18 +337,18 @@ (define CLONE_NEWNET #x40000000)
;; 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.
(define clone
(let* ((ptr (dynamic-func "syscall" (dynamic-link)))
(proc (pointer->procedure long ptr
(list long ;sysno
unsigned-long ;flags
'* '* '*
'*)))
(let* ((proc (syscall->procedure int "syscall"
(list long ;sysno
unsigned-long ;flags
'* '* '*
'*)))
;; TODO: Don't do this.
(syscall-id (match (utsname:machine (uname))
("i686" 120)
("x86_64" 56)
("mips64" 5055)
("armv7l" 120))))
("armv7l" 120)
(_ #f))))
(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
@ -373,8 +383,7 @@ (define setns
(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."