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

list-runtime-roots: Do not use 'lsof'. 

This makes things a bit faster (0.8s instead of 1.4s on my laptop).

* nix/scripts/list-runtime-roots.in (lsof-roots): Remove.
(proc-fd-roots): Return the empty list when 'scandir' returns #f.
(referenced-files): New procedure.
Use it at the top level.
This commit is contained in:
Ludovic Courtès 2017-11-12 22:02:22 +01:00
parent 6a98b9f34e
commit b8f59cdc20
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 20 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
nix/scripts/list-runtime-roots.in
View File

@ -26,7 +26,6 @@
(use-modules (ice-9 ftw) (use-modules (ice-9 ftw)
(ice-9 regex) (ice-9 regex)
(ice-9 rdelim) (ice-9 rdelim)
(ice-9 popen)
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-26) (srfi srfi-26)
(rnrs io ports)) (rnrs io ports))
@ -59,7 +58,7 @@ or the empty list."
(and target (and target
(string-prefix? "/" target) (string-prefix? "/" target)
target))) target)))
(scandir dir string->number)))) (or (scandir dir string->number) '()))))
(define (proc-maps-roots dir) (define (proc-maps-roots dir)
"Return the list of store files referenced by DIR, which is a "Return the list of store files referenced by DIR, which is a
@ -107,61 +106,25 @@ or the empty list."
(call-with-input-file environ (call-with-input-file environ
get-string-all)))) get-string-all))))
(define (lsof-roots) (define (referenced-files)
"Return the list of roots as found by calling `lsof'." "Return the list of referenced store items."
(define parent (getpid)) (append-map (lambda (pid)
(let ((proc (string-append %proc-directory "/" pid)))
(catch 'system-error (catch 'system-error
(lambda ()
(let ((pipe (catch 'system-error
(lambda () (lambda ()
(open-pipe* OPEN_READ "lsof" "-n" "-w" "-F" "n")) (append (proc-exe-roots proc)
(proc-cwd-roots proc)
(proc-fd-roots proc)
(proc-maps-roots proc)
(proc-environ-roots proc)))
(lambda args (lambda args
;; In Guile 2.0.5, when (ice-9 popen) was still written ;; There's a TOCTTOU race that we need to handle.
;; in Scheme, 'open-pipe*' would leave the child process (if (= ENOENT (system-error-errno args))
;; behind it when 'execlp' failed (that was mostly '()
;; harmless though, because the uncaught exception would (apply throw args))))))
;; cause it to terminate after printing a backtrace.) (scandir %proc-directory string->number
;; Make sure that doesn't happen. (lambda (a b)
(if (= (getpid) parent) (< (string->number a) (string->number b))))))
(apply throw args)
(begin
(format (current-error-port)
"failed to execute 'lsof': ~a~%"
(strerror (system-error-errno args)))
(primitive-exit 1)))))))
(define %file-rx
(make-regexp "^n/(.*)$"))
;; We're going to read it all. (for-each (cut simple-format #t "~a~%" <>)
(setvbuf pipe _IOFBF 16384) (delete-duplicates (referenced-files)))
(let loop ((line (read-line pipe))
(roots '()))
(cond ((eof-object? line)
(begin
(close-pipe pipe)
roots))
((regexp-exec %file-rx line)
=>
(lambda (match)
(loop (read-line pipe)
(cons (string-append "/"
(match:substring match 1))
roots))))
(else
(loop (read-line pipe) roots))))))
(lambda _
'())))
(let ((proc (format #f "~a/~a" %proc-directory (getpid))))
(for-each (cut simple-format #t "~a~%" <>)
(delete-duplicates
(let ((proc-roots (if (file-exists? proc)
(append (proc-exe-roots proc)
(proc-cwd-roots proc)
(proc-fd-roots proc)
(proc-maps-roots proc)
(proc-environ-roots proc))
'())))
(append proc-roots (lsof-roots))))))