ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-12 22:26:40 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

syscalls: Avoid repeated calls to 'syscall->procedure'.

Browse source 
Commit 7df4d3465d and others changed
'mount', 'umount', & co. so they would call 'syscall->procedure' at each
call.  This change reverts to the previous behavior, where
'syscall->procedure' is called once.

* guix/build/syscalls.scm (mount, umount, reboot, load-linux-module):
Call 'syscall->procedure' only once.
This commit is contained in:
Ludovic Courtès 2022-09-08 13:46:42 +02:00
parent 392e97ed08
commit 8f53630f2f
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 58 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

114
guix/build/syscalls.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014-2022 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> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@ -549,50 +549,50 @@ (define MNT_DETACH 2)
(define MNT_EXPIRE 4) (define MNT_EXPIRE 4)
(define UMOUNT_NOFOLLOW 8) (define UMOUNT_NOFOLLOW 8)
(define-as-needed (mount source target type (define-as-needed mount
#:optional (flags 0) options
#:key (update-mtab? #f))
"Mount device SOURCE on TARGET as a file system TYPE.
Optionally, FLAGS 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."
;; XXX: '#:update-mtab?' is not implemented by core 'mount'. ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
(let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *)))) (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
(let-values (((ret err) (lambda* (source target type
(proc (if source #:optional (flags 0) options
(string->pointer source) #:key (update-mtab? #f))
%null-pointer) "Mount device SOURCE on TARGET as a file system TYPE.
(string->pointer target) Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h> constants, and
(if type OPTIONS may be a string. When FLAGS contains MS_REMOUNT, SOURCE and TYPE are
(string->pointer type) ignored. When UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error'
%null-pointer) exception on error."
flags (let-values (((ret err)
(if options (proc (if source
(string->pointer options) (string->pointer source)
%null-pointer)))) %null-pointer)
(unless (zero? ret) (string->pointer target)
(throw 'system-error "mount" "mount ~S on ~S: ~A" (if type
(list source target (strerror err)) (string->pointer type)
(list err))) %null-pointer)
(when update-mtab? flags
(augment-mtab source target type options))))) (if options
(string->pointer options)
%null-pointer))))
(unless (zero? ret)
(throw 'system-error "mount" "mount ~S on ~S: ~A"
(list source target (strerror err))
(list err)))
(when update-mtab?
(augment-mtab source target type options))))))
(define-as-needed (umount target (define-as-needed umount
#:optional (flags 0)
#:key (update-mtab? #f))
"Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
constants from <sys/mount.h>."
;; XXX: '#:update-mtab?' is not implemented by core 'umount'. ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
(let ((proc (syscall->procedure int "umount2" `(* ,int)))) (let ((proc (syscall->procedure int "umount2" `(* ,int)))) ;XXX
(let-values (((ret err) (lambda* (target #:optional (flags 0) #:key (update-mtab? #f))
(proc (string->pointer target) flags))) "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
(unless (zero? ret) constants from <sys/mount.h>."
(throw 'system-error "umount" "~S: ~A" (let-values (((ret err)
(list target (strerror err)) (proc (string->pointer target) flags)))
(list err))) (unless (zero? ret)
(when update-mtab? (throw 'system-error "umount" "~S: ~A"
(remove-from-mtab target))))) (list target (strerror err))
(list err)))
(when update-mtab?
(remove-from-mtab target))))))
;; Mount point information. ;; Mount point information.
(define-record-type <mount> (define-record-type <mount>
@ -732,25 +732,27 @@ (define-as-needed RB_POWER_OFF #x4321fedc)
(define-as-needed RB_SW_SUSPEND #xd000fce2) (define-as-needed RB_SW_SUSPEND #xd000fce2)
(define-as-needed RB_KEXEC #x45584543) (define-as-needed RB_KEXEC #x45584543)
(define-as-needed (reboot #:optional (cmd RB_AUTOBOOT)) (define-as-needed reboot
(let ((proc (syscall->procedure int "reboot" (list int)))) (let ((proc (syscall->procedure int "reboot" (list int))))
(let-values (((ret err) (proc cmd))) (lambda* (#:optional (cmd RB_AUTOBOOT))
(unless (zero? ret) (let-values (((ret err) (proc cmd)))
(throw 'system-error "reboot" "~S: ~A" (unless (zero? ret)
(list cmd (strerror err)) (throw 'system-error "reboot" "~S: ~A"
(list err)))))) (list cmd (strerror err))
(list err)))))))
(define-as-needed (load-linux-module data #:optional (options "")) (define-as-needed load-linux-module
(let ((proc (syscall->procedure int "init_module" (let ((proc (syscall->procedure int "init_module"
(list '* unsigned-long '*)))) (list '* unsigned-long '*))))
(let-values (((ret err) (lambda* (data #:optional (options ""))
(proc (bytevector->pointer data) (let-values (((ret err)
(bytevector-length data) (proc (bytevector->pointer data)
(string->pointer options)))) (bytevector-length data)
(unless (zero? ret) (string->pointer options))))
(throw 'system-error "load-linux-module" "~A" (unless (zero? ret)
(list (strerror err)) (throw 'system-error "load-linux-module" "~A"
(list err)))))) (list (strerror err))
(list err)))))))
(define (kernel? pid) (define (kernel? pid)
"Return #t if PID designates a \"kernel thread\" rather than a normal "Return #t if PID designates a \"kernel thread\" rather than a normal