diff options
| -rw-r--r-- | gnu/installer/parted.scm | 27 | ||||
| -rw-r--r-- | gnu/installer/utils.scm | 14 |
2 files changed, 28 insertions, 13 deletions
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index f592d315f5..9ef263d1f9 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -41,6 +41,7 @@ #:use-module (ice-9 regex) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -318,7 +319,7 @@ PARTED-OBJECT field equals PARTITION, return #f if not found." fail. See rereadpt function in wipefs.c of util-linux for an explanation." ;; Kernel always return EINVAL for BLKRRPART on loopdevices. (and (not (string-match "/dev/loop*" file-name)) - (let loop ((try 4)) + (let loop ((try 16)) (usleep 250000) (let ((in-use? (device-in-use? file-name))) (if (and in-use? (> try 0)) @@ -339,15 +340,12 @@ fail. See rereadpt function in wipefs.c of util-linux for an explanation." (define (non-install-devices) "Return all the available devices, except the busy one, allegedly the install device. DEVICE-IS-BUSY? is a parted call, checking if the device is -mounted. The install image uses an overlayfs so the install device does not -appear as mounted and won't be considered as busy. So use also DEVICE-IN-USE? -from (guix build syscalls) module, who will try to re-read the device's -partition table to determine whether or not it is already used (like sfdisk -from util-linux)." +mounted." + ;; FIXME: The install image uses an overlayfs so the install device does not + ;; appear as mounted and won't be considered as busy. (remove (lambda (device) (let ((file-name (device-path device))) - (or (device-is-busy? device) - (with-delay-device-in-use? file-name)))) + (device-is-busy? device))) (devices))) @@ -1390,9 +1388,12 @@ the devices not to be used before returning." (let ((device-file-names (map device-path devices))) (for-each force-device-sync devices) (for-each (lambda (file-name) - (let ((in-use? (with-delay-device-in-use? file-name))) - (and in-use? - (error - (format #f (G_ "Device ~a is still in use.") - file-name))))) + (let/time ((time in-use? + (with-delay-device-in-use? file-name))) + (if in-use? + (error + (format #f (G_ "Device ~a is still in use.") + file-name)) + (syslog "Syncing ~a took ~a seconds.~%" + file-name (time-second time))))) device-file-names))) diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm index 5f8fe8ca01..a7fa66a199 100644 --- a/gnu/installer/utils.scm +++ b/gnu/installer/utils.scm @@ -22,6 +22,7 @@ #:use-module (guix build utils) #:use-module (guix i18n) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-34) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -36,6 +37,8 @@ syslog-port syslog + call-with-time + let/time with-server-socket current-server-socket @@ -117,6 +120,17 @@ COMMAND exited successfully, #f otherwise." ;;; Logging. ;;; +(define (call-with-time thunk kont) + "Call THUNK and pass KONT the elapsed time followed by THUNK's return +values." + (let* ((start (current-time time-monotonic)) + (result (call-with-values thunk list)) + (end (current-time time-monotonic))) + (apply kont (time-difference end start) result))) + +(define-syntax-rule (let/time ((time result exp)) body ...) + (call-with-time (lambda () exp) (lambda (time result) body ...))) + (define (open-syslog-port) "Return an open port (a socket) to /dev/log or #f if that wasn't possible." (let ((sock (socket AF_UNIX SOCK_DGRAM 0))) |